module Language.Core.ParsecParser (parseCore, coreModuleName, coreTcon,
coreQualifiedGen, upperName, identifier, coreType, coreKind,
coreTbinds, parens, braces, topVbind) where
import Language.Core.Core
import Language.Core.Check
import Language.Core.Encoding
import Language.Core.PrimCoercions
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Data.Char
import Data.List
import Data.Ratio
parseCore :: FilePath -> IO (Either ParseError Module)
parseCore = parseFromFile coreModule
coreModule :: Parser Module
coreModule = do
whiteSpace
reserved "module"
mName <- coreModuleName
whiteSpace
tdefs <- option [] coreTdefs
vdefGroups <- coreVdefGroups
eof
return $ Module mName tdefs vdefGroups
coreModuleName :: Parser AnMname
coreModuleName = do
pkgName <- corePackageName
char ':'
(modHierarchy,baseName) <- coreHierModuleNames
return $ M (pkgName, modHierarchy, baseName)
corePackageName :: Parser Pname
corePackageName = (identifier <|> upperName) >>= (return . P)
coreHierModuleNames :: Parser ([Id], Id)
coreHierModuleNames = do
parentName <- upperName
return $ splitModuleName parentName
upperName :: Parser Id
upperName = do
firstChar <- upper
rest <- many (identLetter extCoreDef)
return $ firstChar:rest
coreTdefs :: Parser [Tdef]
coreTdefs = many coreTdef
coreTdef :: Parser Tdef
coreTdef = withSemi (try (try coreDataDecl <|> try coreNewtypeDecl))
withSemi p = try p `withTerminator` ";"
withTerminator p term = do
x <- try p
try $ symbol term
return x
coreDataDecl :: Parser Tdef
coreDataDecl = do
reserved "data"
tyCon <- coreQualifiedCon
whiteSpace
tBinds <- coreTbinds
whiteSpace
symbol "="
whiteSpace
cDefs <- braces coreCdefs
return $ Data tyCon tBinds cDefs
coreNewtypeDecl :: Parser Tdef
coreNewtypeDecl = do
reserved "newtype"
tyCon <- coreQualifiedCon
whiteSpace
coercionName <- coreQualifiedCon
whiteSpace
tBinds <- coreTbinds
tyRep <- try coreTRep
return $ Newtype tyCon coercionName tBinds tyRep
coreQualifiedCon :: Parser (Mname, Id)
coreQualifiedCon = coreQualifiedGen upperName
coreQualifiedName = coreQualifiedGen identifier
coreQualifiedGen :: Parser String -> Parser (Mname, Id)
coreQualifiedGen p = (try (do
packageIdOrVarName <- corePackageName
maybeRest <- optionMaybe (char ':' >> coreHierModuleNames)
case maybeRest of
Nothing -> pzero
Just (modHierarchy, baseName) -> do
char '.'
theId <- p
return
(Just $ M (packageIdOrVarName, modHierarchy, baseName),
theId))) <|>
(p >>= (\ res -> return (Nothing, res)))
coreTbinds :: Parser [Tbind]
coreTbinds = many coreTbind
coreTbindsGen :: CharParser () String -> Parser [Tbind]
coreTbindsGen separator = many (try $ coreTbindGen separator)
coreTbind :: Parser Tbind
coreTbind = coreTbindGen whiteSpace
coreTbindGen :: CharParser () a -> Parser Tbind
coreTbindGen sep = (parens (do
sep
tyVar <- identifier
kind <- symbol "::" >> coreKind
return (tyVar, kind))) <|>
(sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
coreCdefs :: Parser [Cdef]
coreCdefs = sepBy coreCdef (symbol ";")
coreCdef :: Parser Cdef
coreCdef = do
dataConName <- coreQualifiedCon
whiteSpace
tBinds <- try $ coreTbindsGen (symbol "@")
tys <- sepBy coreAtySaturated whiteSpace
return $ Constr dataConName tBinds tys
coreTRep :: Parser Ty
coreTRep = symbol "=" >> try coreType
coreType :: Parser Ty
coreType = coreForallTy <|> (do
hd <- coreBty
whiteSpace
maybeRest <- option [] (many1 (symbol "->" >> coreType))
return $ case maybeRest of
[] -> hd
stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
coreBty :: Parser Ty
coreBty = do
hd <- coreAty
maybeRest <- option [] (many1 (try (whiteSpace >> coreAtySaturated)))
return $ (case hd of
ATy t -> foldl Tapp t maybeRest
Trans k -> app k 2 maybeRest "trans"
Sym k -> app k 1 maybeRest "sym"
Unsafe k -> app k 2 maybeRest "unsafe"
LeftCo k -> app k 1 maybeRest "left"
RightCo k -> app k 1 maybeRest "right"
InstCo k -> app k 2 maybeRest "inst")
where app k arity args _ | length args == arity = k args
app _ _ args err =
primCoercionError (err ++
("Args were: " ++ show args))
coreAtySaturated :: Parser Ty
coreAtySaturated = do
t <- coreAty
case t of
ATy ty -> return ty
_ -> unexpected "coercion ty"
coreAty :: Parser ATyOp
coreAty = try coreTcon <|> ((try coreTvar <|> parens coreType)
>>= return . ATy)
coreTvar :: Parser Ty
coreTvar = try identifier >>= (return . Tvar)
coreTcon :: Parser ATyOp
coreTcon =
try (do
maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
try instCo, try leftCo, rightCo]
return $ case maybeCoercion of
TransC -> Trans (\ [x,y] -> TransCoercion x y)
SymC -> Sym (\ [x] -> SymCoercion x)
UnsafeC -> Unsafe (\ [x,y] -> UnsafeCoercion x y)
LeftC -> LeftCo (\ [x] -> LeftCoercion x)
RightC -> RightCo (\ [x] -> RightCoercion x)
InstC -> InstCo (\ [x,y] -> InstCoercion x y))
<|> (coreQualifiedCon >>= (return . ATy . Tcon))
data CoercionTy = TransC | InstC | SymC | UnsafeC | LeftC | RightC
symCo, transCo, unsafeCo, instCo, leftCo, rightCo :: Parser CoercionTy
symCo = string "%sym" >> return SymC
transCo = string "%trans" >> return TransC
unsafeCo = string "%unsafe" >> return UnsafeC
leftCo = string "%left" >> return LeftC
rightCo = string "%right" >> return RightC
instCo = string "%inst" >> return InstC
coreForallTy :: Parser Ty
coreForallTy = do
reserved "forall"
tBinds <- many1 coreTbind
symbol "."
bodyTy <- coreType
return $ foldr Tforall bodyTy tBinds
coreKind :: Parser Kind
coreKind = do
hd <- coreAtomicKind
maybeRest <- option [] (many1 (symbol "->" >> coreKind))
return $ foldl Karrow hd maybeRest
coreAtomicKind = try liftedKind <|> try unliftedKind
<|> try openKind <|> try (do
(from,to) <- parens equalityKind
return $ Keq from to)
<|> try (parens coreKind)
liftedKind = do
symbol "*"
return Klifted
unliftedKind = do
symbol "#"
return Kunlifted
openKind = do
symbol "?"
return Kopen
equalityKind = do
ty1 <- coreBty
symbol ":=:"
ty2 <- coreBty
return (ty1, ty2)
data ATyOp =
ATy Ty
| Trans ([Ty] -> Ty)
| Sym ([Ty] -> Ty)
| Unsafe ([Ty] -> Ty)
| LeftCo ([Ty] -> Ty)
| RightCo ([Ty] -> Ty)
| InstCo ([Ty] -> Ty)
coreVdefGroups :: Parser [Vdefg]
coreVdefGroups = option [] (do
theFirstVdef <- coreVdefg
symbol ";"
others <- coreVdefGroups
return $ theFirstVdef:others)
coreVdefg :: Parser Vdefg
coreVdefg = coreRecVdef <|> coreNonrecVdef
coreRecVdef = do
reserved "rec"
braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
coreNonrecVdef = coreVdef >>= (return . Nonrec)
coreVdef = do
(vdefLhs, vdefTy) <- try topVbind <|> (do
(v, ty) <- lambdaBind
return (unqual v, ty))
whiteSpace
symbol "="
whiteSpace
vdefRhs <- coreFullExp
return $ Vdef (vdefLhs, vdefTy, vdefRhs)
coreAtomicExp :: Parser Exp
coreAtomicExp = do
whiteSpace
res <- choice [try coreDconOrVar,
try coreLit,
parens coreFullExp ]
whiteSpace
return res
coreFullExp = (choice [coreLam, coreLet,
coreCase, coreCast, coreNote, coreExternal, coreLabel]) <|> (try coreAppExp)
<|> coreAtomicExp
coreAppExp = do
oper <- try coreAtomicExp
whiteSpace
args <- many1 (whiteSpace >> ((coreAtomicExp >>= (return . Left)) <|>
((symbol "@" >> coreAtySaturated) >>= (return . Right))))
return $ foldl (\ op ->
either (App op) (Appt op)) oper args
coreDconOrVar = do
theThing <- coreQualifiedGen (try upperName <|> identifier)
return $ case theThing of
(Just _, idItself) | isUpper (head idItself)
-> Dcon theThing
_ -> Var theThing
coreLit :: Parser Exp
coreLit = parens (coreLiteral >>= (return . Lit))
coreLiteral :: Parser Lit
coreLiteral = do
l <- try aLit
symbol "::"
t <- coreType
return $ Literal l t
coreLam = do
symbol "\\"
binds <- coreLambdaBinds
symbol "->"
body <- coreFullExp
return $ foldr Lam body binds
coreLet = do
reserved "let"
vdefg <- coreVdefg
whiteSpace
reserved "in"
body <- coreFullExp
return $ Let vdefg body
coreCase = do
reserved "case"
ty <- coreAtySaturated
scrut <- coreAtomicExp
reserved "of"
vBind <- parens lambdaBind
alts <- coreAlts
return $ Case scrut vBind ty alts
coreCast = do
reserved "cast"
whiteSpace
body <- try (parens coreFullExp)
whiteSpace
ty <- try coreAtySaturated
return $ Cast body ty
coreNote = do
reserved "note"
s <- stringLiteral
e <- coreFullExp
return $ Note s e
coreExternal = (do
reserved "external"
symbol "ccall"
s <- stringLiteral
t <- coreAtySaturated
return $ External s t) <|>
(do
reserved "dynexternal"
symbol "ccall"
t <- coreAtySaturated
return $ External "[dynamic]" t)
coreLabel = do
reserved "label"
s <- stringLiteral
return $ External s tAddrzh
coreLambdaBinds = many1 coreBind
coreBind = coreTbinding <|> coreVbind
coreTbinding = try coreAtTbind >>= (return . Tb)
coreVbind = parens (lambdaBind >>= (return . Vb))
coreAtTbind = (symbol "@") >> coreTbind
topVbind :: Parser (Qual Var, Ty)
topVbind = aCoreVbind coreQualifiedName
lambdaBind :: Parser (Var, Ty)
lambdaBind = aCoreVbind identifier
aCoreVbind idP = do
nm <- idP
symbol "::"
t <- coreType
return (nm, t)
aLit :: Parser CoreLit
aLit = intOrRatLit <|> charLit <|> stringLit
intOrRatLit :: Parser CoreLit
intOrRatLit = do
lhs <- intLit
maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
case maybeRhs of
Nothing -> return $ Lint lhs
Just rhs -> return $ Lrational (lhs % rhs)
intLit :: Parser Integer
intLit = anIntLit <|> parens anIntLit
anIntLit :: Parser Integer
anIntLit = do
sign <- option 1 (symbol "-" >> return (1))
n <- natural
return (sign * n)
charLit :: Parser CoreLit
charLit = charLiteral >>= (return . Lchar)
stringLit :: Parser CoreLit
stringLit = stringLiteral >>= (return . Lstring)
coreAlts :: Parser [Alt]
coreAlts = braces $ sepBy1 coreAlt (symbol ";")
coreAlt :: Parser Alt
coreAlt = conAlt <|> litAlt <|> defaultAlt
conAlt :: Parser Alt
conAlt = do
conName <- coreQualifiedCon
whiteSpace
(tBinds, vBinds) <- caseVarBinds
try (symbol "->")
rhs <- try coreFullExp
return $ Acon conName tBinds vBinds rhs
caseVarBinds :: Parser ([Tbind], [Vbind])
caseVarBinds = do
maybeFirstTbind <- optionMaybe coreAtTbind
case maybeFirstTbind of
Just tb -> do
(tbs,vbs) <- caseVarBinds
return (tb:tbs, vbs)
Nothing -> do
vbs <- many (parens lambdaBind)
return ([], vbs)
litAlt :: Parser Alt
litAlt = do
l <- parens coreLiteral
symbol "->"
rhs <- coreFullExp
return $ Alit l rhs
defaultAlt :: Parser Alt
defaultAlt = do
reserved "_"
symbol "->"
rhs <- coreFullExp
return $ Adefault rhs
splitModuleName mn =
let decoded = zDecodeString mn
parts = map zEncodeString $ filter (notElem '.') $ groupBy
(\ c1 c2 -> c1 /= '.' && c2 /= '.')
decoded in
(take (length parts 1) parts, last parts)
extCore = P.makeTokenParser extCoreDef
parens = P.parens extCore
braces = P.braces extCore
whiteSpace = P.whiteSpace extCore <|> (newline >> return ())
symbol = P.symbol extCore
identifier = P.identifier extCore
reserved s = P.reserved extCore ('%':s)
natural = P.natural extCore
charLiteral = P.charLiteral extCore
stringLiteral = P.stringLiteral extCore
extCoreDef = LanguageDef {
commentStart = "{-"
, commentEnd = "-}"
, commentLine = "--"
, nestedComments = True
, identStart = lower
, identLetter = lower <|> upper <|> digit <|> (char '\'')
, opStart = opLetter extCoreDef
, opLetter = oneOf ";=@:\\%_.*#?%"
, reservedNames = map ('%' :)
["module", "data", "newtype", "rec",
"let", "in", "case", "of", "cast",
"note", "external", "forall"]
, reservedOpNames = [";", "=", "@", "::", "\\", "%_",
".", "*", "#", "?"]
, caseSensitive = True
}