lambdacube-compiler-0.4.0.0: src/LambdaCube/Compiler/Lexer.hs
-- contains modified Haskell source code copied from Text.Parsec.Token, see below
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance NFData SourcePos
{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
module LambdaCube.Compiler.Lexer
( module LambdaCube.Compiler.Lexer
, module Pr
) where
import Data.Monoid
import Data.Maybe
import Data.List
import Data.Char
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Arrow hiding ((<+>))
import Control.Applicative
import Control.DeepSeq
import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens)
--------------------- parsec specific code begins here
import Text.Parsec hiding ((<|>), many)
import Text.Parsec as Pr hiding (label, Empty, State, (<|>), many, try)
import qualified Text.Parsec as Pa
import Text.Parsec.Indentation as Pa
import Text.Parsec.Indentation.Char
import Text.Parsec.Pos
skipSome = skipMany1
type P = ParsecT (IndentStream (CharIndentStream String)) SourcePos InnerP
indent s p = reserved s *> localIndentation Ge (localAbsoluteIndentation p)
indented = localIndentation Gt
indentMany s p = indent s $ many p
indentSome s p = indent s $ some p
indentMany' = many
whiteSpace = ignoreAbsoluteIndentation (localTokenMode (const Pa.Any) whiteSpace')
lexeme p
= p <* (getPosition >>= setState >> whiteSpace)
mkStream = mkIndentStream 0 infIndentation True Ge . mkCharIndentStream
runPT' p st --u name s
= do res <- runParsecT p st -- (Pa.State s (initialPos name) u)
r <- parserReply res
case r of
Ok x _ _ -> return (Right x)
Error err -> return (Left err)
where
parserReply res
= case res of
Consumed r -> r
Pa.Empty r -> r
runParserT'' p f = runParserT p (initialPos f) f
--------------------- parsec specific code ends here
{-
--------------------- megaparsec specific code begins here
import Control.Monad.State
import Text.Megaparsec
import Text.Megaparsec.Lexer hiding (lexeme, symbol, space, negate)
import Text.Megaparsec as Pr hiding (try, label, Message)
import Text.Megaparsec.Pos
optionMaybe = optional
runParserT'' p f = flip evalStateT (initialPos f, 0) . runParserT p f
runPT' p st = snd <$> flip evalStateT (initialPos ".....", 0) (runParserT' p st)
mkStream = id
hexDigit = hexDigitChar
octDigit = octDigitChar
digit = digitChar
getState = fst <$> get
type P = ParsecT String (StateT (SourcePos, Int) InnerP)
indentMany' p = --many p--
indentBlock whiteSpace' $ whiteSpace' >> return (IndentMany Nothing return p)
indentMany s p = indentBlock whiteSpace' $ try (reserved s) *> return (IndentMany Nothing return p)
indentSome s p = indentBlock whiteSpace' $ try (reserved s) *> return (IndentSome Nothing return p)
indented p = do
i <- indentLevel
modify $ second $ const i
--p <* indentGuard whiteSpace' (>= i)
p
lexeme p = do
i <- indentLevel
i' <- snd <$> get
-- when (i < i') $ fail "indent level"
p <* (getPosition >>= \p -> modify (first $ const p) >> whiteSpace)
whiteSpace = whiteSpace'
--------------------- megaparsec specific code ends here
-}
-------------------------------------------------------------------------------- parser utils
-- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602
try_ s m = try m <?> s
manyNM a b _ | b < a || b < 0 || a < 0 = mzero
manyNM 0 0 _ = pure []
manyNM 0 n p = option [] $ (:) <$> p <*> manyNM 0 (n-1) p
manyNM k n p = (:) <$> p <*> manyNM (k-1) (n-1) p
-------------------------------------------------------------------------------- parser type
type InnerP = WriterT [PostponedCheck] (Reader (DesugarInfo, Namespace))
type PostponedCheck = Maybe String
type DesugarInfo = (FixityMap, ConsMap)
type ConsMap = Map.Map SName{-constructor name-}
(Either ((SName{-type name-}, Int{-num of indices-}), [(SName, Int)]{-constructors with arities-})
Int{-arity-})
dsInfo :: P DesugarInfo
dsInfo = asks fst
namespace :: P Namespace
namespace = asks snd
-------------------------------------------------------------------------------- literals
data Lit
= LInt Integer
| LChar Char
| LFloat Double
| LString String
deriving (Eq)
instance Show Lit where
show = \case
LFloat x -> show x
LString x -> show x
LInt x -> show x
LChar x -> show x
-------------------------------------------------------------------------------- names
type SName = String
caseName (c:cs) = toLower c: cs ++ "Case"
pattern MatchName cs <- (getMatchName -> Just cs) where MatchName = matchName
matchName cs = "match" ++ cs
getMatchName ('m':'a':'t':'c':'h':cs) = Just cs
getMatchName _ = Nothing
-------------------------------------------------------------------------------- source infos
instance NFData SourcePos where
rnf x = x `seq` ()
data Range = Range SourcePos SourcePos
deriving (Eq, Ord)
instance NFData Range where
rnf (Range a b) = rnf a `seq` rnf b `seq` ()
instance PShow Range where
pShowPrec _ (Range b e) | sourceName b == sourceName e = text (sourceName b) <+> f b <> "-" <> f e
where
f x = pShow (sourceLine x) <> ":" <> pShow (sourceColumn x)
joinRange :: Range -> Range -> Range
joinRange (Range b e) (Range b' e') = Range (min b b') (max e e')
data SI
= NoSI (Set.Set String) -- no source info, attached debug info
| RangeSI Range
instance Show SI where show _ = "SI"
instance Eq SI where _ == _ = True
instance Ord SI where _ `compare` _ = EQ
instance Monoid SI where
mempty = NoSI Set.empty
mappend (RangeSI r1) (RangeSI r2) = RangeSI (joinRange r1 r2)
mappend (NoSI ds1) (NoSI ds2) = NoSI (ds1 `Set.union` ds2)
mappend r@RangeSI{} _ = r
mappend _ r@RangeSI{} = r
instance PShow SI where
pShowPrec _ (NoSI ds) = hsep $ map pShow $ Set.toList ds
pShowPrec _ (RangeSI r) = pShow r
showSI_ _ (NoSI ds) = unwords $ Set.toList ds
showSI_ source (RangeSI (Range s e)) = show str
where
startLine = sourceLine s - 1
endline = sourceLine e - if sourceColumn e == 1 then 1 else 0
len = endline - startLine
str = vcat $ text (show s <> ":"){- <+> "-" <+> text (show e)-}:
map text (take len $ drop startLine $ lines source)
++ [text $ replicate (sourceColumn s - 1) ' ' ++ replicate (sourceColumn e - sourceColumn s) '^' | len == 1]
showSourcePosSI (NoSI ds) = unwords $ Set.toList ds
showSourcePosSI (RangeSI (Range s _)) = show s
-- TODO: remove
validSI RangeSI{} = True
validSI _ = False
debugSI a = NoSI (Set.singleton a)
si@(RangeSI r) `validate` xs | all validSI xs && r `notElem` [r | RangeSI r <- xs] = si
_ `validate` _ = mempty
sourceNameSI (RangeSI (Range a _)) = sourceName a
sameSource r@(RangeSI {}) q@(RangeSI {}) = sourceNameSI r == sourceNameSI q
sameSource _ _ = True
class SourceInfo si where
sourceInfo :: si -> SI
instance SourceInfo SI where
sourceInfo = id
instance SourceInfo si => SourceInfo [si] where
sourceInfo = foldMap sourceInfo
class SetSourceInfo a where
setSI :: SI -> a -> a
appRange :: P (SI -> a) -> P a
appRange p = (\p1 a p2 -> a $ RangeSI $ Range p1 p2) <$> getPosition <*> p <*> getState
withRange :: (SI -> a -> b) -> P a -> P b
withRange f p = appRange $ flip f <$> p
infix 9 `withRange`
type SIName = (SI, SName)
parseSIName :: P String -> P SIName
parseSIName = withRange (,)
-------------------------------------------------------------------------------- namespace handling
data Level = TypeLevel | ExpLevel
deriving (Eq, Show)
data Namespace = Namespace
{ namespaceLevel :: Maybe Level
, constructorNamespace :: Bool -- True means that the case of the first letter of identifiers matters
}
deriving (Show)
tick = (\case TypeLevel -> switchTick; _ -> id) . fromMaybe ExpLevel . namespaceLevel
tick' c = (`tick` c) <$> namespace
switchTick ('\'': n) = n
switchTick n = '\'': n
modifyLevel f = local $ second $ \(Namespace l p) -> Namespace (f <$> l) p
typeNS, expNS, switchNS :: P a -> P a
typeNS = modifyLevel $ const TypeLevel
expNS = modifyLevel $ const ExpLevel
switchNS = modifyLevel $ \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel
ifNoCNamespace p = namespace >>= \ns -> if constructorNamespace ns then mzero else p
-------------------------------------------------------------------------------- identifiers
lcIdentStart = satisfy $ \c -> isLower c || c == '_'
identStart = satisfy $ \c -> isLetter c || c == '_'
identLetter = satisfy $ \c -> isAlphaNum c || c == '_' || c == '\'' || c == '#'
lowercaseOpLetter = oneOf "!#$%&*+./<=>?@\\^|-~"
opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
maybeStartWith p i = i <|> (:) <$> satisfy p <*> i
lowerLetter = lcIdentStart <|> ifNoCNamespace identStart
upperLetter = satisfy isUpper <|> ifNoCNamespace identStart
upperCase, lowerCase, symbols, colonSymbols, backquotedIdent :: P SName
upperCase = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident"
lowerCase = identifier ((:) <$> lowerLetter <*> many identLetter) <?> "lowercase ident"
backquotedIdent = identifier ((:) <$ char '`' <*> identStart <*> many identLetter <* char '`') <?> "backquoted ident"
symbols = operator (some opLetter) <?> "symbols"
lcSymbols = operator ((:) <$> lowercaseOpLetter <*> many opLetter) <?> "symbols"
colonSymbols = operator ((:) <$> satisfy (== ':') <*> many opLetter) <?> "op symbols"
moduleName = identifier (intercalate "." <$> sepBy1 ((:) <$> upperLetter <*> many identLetter) (char '.')) <?> "module name"
patVar = f <$> lowerCase where
f "_" = ""
f x = x
lhsOperator = lcSymbols <|> backquotedIdent
rhsOperator = symbols <|> backquotedIdent
varId = lowerCase <|> parens rhsOperator
upperLower = lowerCase <|> upperCase <|> parens rhsOperator
--qIdent = {-qualified_ todo-} (lowerCase <|> upperCase)
-------------------------------------------------------------------------------- fixity handling
data FixityDef = Infix | InfixL | InfixR deriving (Show)
type Fixity = (FixityDef, Int)
type MFixity = Maybe Fixity
type FixityMap = Map.Map SName Fixity
calcPrec
:: (Show e, Show f)
=> (f -> e -> e -> e)
-> (f -> Fixity)
-> e
-> [(f, e)]
-> e
calcPrec app getFixity e = compileOps [((Infix, -1000), error "calcPrec", e)]
where
compileOps [(_, _, e)] [] = e
compileOps acc [] = compileOps (shrink acc) []
compileOps acc@((p, g, e1): ee) es_@((op, e'): es) = case compareFixity (pr, op) (p, g) of
Right GT -> compileOps ((pr, op, e'): acc) es
Right LT -> compileOps (shrink acc) es_
Left err -> error err
where
pr = getFixity op
shrink ((_, op, e): (pr, op', e'): es) = (pr, op', app op e' e): es
compareFixity ((dir, i), op) ((dir', i'), op')
| i > i' = Right GT
| i < i' = Right LT
| otherwise = case (dir, dir') of
(InfixL, InfixL) -> Right LT
(InfixR, InfixR) -> Right GT
_ -> Left $ "fixity error:" ++ show (op, op')
parseFixityDecl :: P [(SIName, Fixity)]
parseFixityDecl = do
dir <- Infix <$ reserved "infix"
<|> InfixL <$ reserved "infixl"
<|> InfixR <$ reserved "infixr"
indented $ do
LInt n <- parseLit
let i = fromIntegral n
ns <- commaSep1 (parseSIName rhsOperator)
return $ (,) <$> ns <*> pure (dir, i)
getFixity :: DesugarInfo -> SName -> Fixity
getFixity (fm, _) n = fromMaybe (InfixL, 9) $ Map.lookup n fm
----------------------------------------------------------------------
----------------------------------------------------------------------
-- modified version of
--
-- Module : Text.Parsec.Token
-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
-- License : BSD-style
-----------------------------------------------------------
-- Bracketing
-----------------------------------------------------------
parens p = between (symbol "(") (symbol ")") p
braces p = between (symbol "{") (symbol "}") p
angles p = between (symbol "<") (symbol ">") p
brackets p = between (symbol "[") (symbol "]") p
commaSep p = sepBy p $ symbol ","
commaSep1 p = sepBy1 p $ symbol ","
-----------------------------------------------------------
parseLit = lexeme $ charLiteral <|> stringLiteral <|> natFloat
where
-----------------------------------------------------------
-- Chars & Strings
-----------------------------------------------------------
charLiteral = LChar <$> between (char '\'')
(char '\'' <?> "end of character")
characterChar
<?> "character"
characterChar = charLetter <|> charEscape
<?> "literal character"
charEscape = do{ char '\\'; escapeCode }
charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
stringLiteral = LString <$>
do{ str <- between (char '"')
(char '"' <?> "end of string")
(many stringChar)
; return (foldr (maybe id (:)) "" str)
}
<?> "literal string"
stringChar = do{ c <- stringLetter; return (Just c) }
<|> stringEscape
<?> "string character"
stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
stringEscape = do{ char '\\'
; do{ escapeGap ; return Nothing }
<|> do{ escapeEmpty; return Nothing }
<|> do{ esc <- escapeCode; return (Just esc) }
}
escapeEmpty = char '&'
escapeGap = do{ some space
; char '\\' <?> "end of string gap"
}
-- escape codes
escapeCode = charEsc <|> charNum <|> charAscii <|> charControl
<?> "escape code"
charControl = do{ char '^'
; code <- satisfy isUpper <?> "uppercase letter"
; return (toEnum (fromEnum code - fromEnum 'A'))
}
charNum = do{ code <- decimal
<|> do{ char 'o'; number 8 octDigit }
<|> do{ char 'x'; number 16 hexDigit }
; return (toEnum (fromInteger code))
}
charEsc = choice (map parseEsc escMap)
where
parseEsc (c,code) = do{ char c; return code }
charAscii = choice (map parseAscii asciiMap)
where
parseAscii (asc,code) = try (do{ string asc; return code })
-- escape code tables
escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")
asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",
"FS","GS","RS","US","SP"]
ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",
"DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",
"CAN","SUB","ESC","DEL"]
ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',
'\EM','\FS','\GS','\RS','\US','\SP']
ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',
'\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',
'\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']
-----------------------------------------------------------
-- Numbers
-----------------------------------------------------------
-- floats
natFloat = do{ char '0'
; zeroNumFloat
}
<|> decimalFloat
zeroNumFloat = do{ n <- hexadecimal <|> octal
; return (LInt n)
}
<|> decimalFloat
<|> fractFloat 0
<|> return (LInt 0)
decimalFloat = do{ n <- decimal
; option (LInt n)
(fractFloat n)
}
fractFloat n = do{ f <- fractExponent n
; return (LFloat f)
}
fractExponent n = do{ fract <- fraction
; expo <- option 1.0 exponent'
; return ((fromInteger n + fract)*expo)
}
<|>
do{ expo <- exponent'
; return ((fromInteger n)*expo)
}
fraction = do{ char '.'
; digits <- some digit <?> "fraction"
; return (foldr op 0.0 digits)
}
<?> "fraction"
where
op d f = (f + fromIntegral (digitToInt d))/10.0
exponent' = do{ oneOf "eE"
; f <- sign
; e <- decimal <?> "exponent"
; return (power (f e))
}
<?> "exponent"
where
power e | e < 0 = 1.0/power(-e)
| otherwise = fromInteger (10^e)
-- integers and naturals
sign = (char '-' >> return negate)
<|> (char '+' >> return id)
<|> return id
decimal = number 10 digit
hexadecimal = do{ oneOf "xX"; number 16 hexDigit }
octal = do{ oneOf "oO"; number 8 octDigit }
number base baseDigit
= do{ digits <- some baseDigit
; let n = foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits
; seq n (return n)
}
-----------------------------------------------------------
-- Operators & reserved ops
-----------------------------------------------------------
reservedOp name =
lexeme $ try $
do{ string name
; notFollowedBy opLetter <?> ("end of " ++ show name)
}
operator oper =
lexeme $ try $ trCons <$> expect "reserved operator" (`Set.member` theReservedOpNames) oper
where
trCons ":" = "Cons"
trCons x = x
theReservedOpNames = Set.fromList ["::","..","=","\\","|","<-","->","@","~","=>"]
expect msg p i = i >>= \n -> if (p n) then unexpected (msg ++ " " ++ show n) else return n
-----------------------------------------------------------
-- Identifiers & Reserved words
-----------------------------------------------------------
reserved name =
lexeme $ try $
do{ string name
; notFollowedBy identLetter <?> ("end of " ++ show name)
}
identifier ident =
lexeme $ try $ expect "reserved word" (`Set.member` theReservedNames) ident
theReservedNames = Set.fromList $
["let","in","case","of","if","then","else"
,"data","type"
,"class","default","deriving","do","import"
,"infix","infixl","infixr","instance","module"
,"newtype","where"
,"primitive"
-- "as","qualified","hiding"
] ++
["foreign","import","export","primitive"
,"_ccall_","_casm_"
,"forall"
]
-----------------------------------------------------------
-- White space & symbols
-----------------------------------------------------------
symbol name
= lexeme (string name)
whiteSpace' = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
simpleSpace
= skipSome (satisfy isSpace)
oneLineComment
= try (string "--" >> many (char '-') >> notFollowedBy opLetter)
>> skipMany (satisfy (/= '\n'))
multiLineComment = try (string "{-") *> inCommentMulti
inCommentMulti
= try (() <$ string "-}")
<|> multiLineComment *> inCommentMulti
<|> skipSome (noneOf "{}-") *> inCommentMulti
<|> oneOf "{}-" *> inCommentMulti
<?> "end of comment"