module Language.Modulo.Parse (
parse,
parseName,
parsePrimType,
parsePrimTypeMaybe,
unsafeParseFile
) where
import Control.Monad
import Control.Arrow
import Data.Monoid
import Data.Default
import Data.Maybe
import qualified Data.List as List
import Control.Applicative hiding ((<|>), optional, many)
import Text.Parsec hiding (parse)
import Text.Parsec.Token
import Text.Parsec.String
import Language.Modulo
import Language.Modulo.Util
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty
parse :: String -> Either ParseError Module
parse = runParser modParser () ""
parseName :: String -> Either ParseError Name
parseName = runParser nameParser () ""
parsePrimType :: String -> Either ParseError PrimType
parsePrimType = fmap unPrimType . runParser primTypeParser () ""
where
unPrimType (PrimType x) = x
parsePrimTypeMaybe :: String -> Maybe PrimType
parsePrimTypeMaybe = eitherToMaybe . parsePrimType
unsafeParseFile :: FilePath -> IO Module
unsafeParseFile path = do
str <- readFile path
case (runParser modParser () path str) of
Left e -> error . show $ e
Right m -> return m
modParser :: Parser Module
modParser = do
optional lspace
doc <- fmap (Doc . fromMaybe "") $ optionMaybe docComment
optional lspace
reserved lexer "module"
optStr <- optionMaybe lstr
name <- modNameParser
llex $ char '{'
imps <- many impParser
docDecls <- many docDeclParser
llex $ char '}'
let opt = def {
optTransient = List.isInfixOf "transient" (fromMaybe "" optStr)
}
return $ Module name opt doc imps docDecls
modNameParser :: Parser ModuleName
modNameParser = do
(x:xs) <- identifier lexer `sepBy1` (string ".")
return . ModuleName $ x :| xs
impParser :: Parser (ModuleName, Maybe String)
impParser = do
reserved lexer "import"
conv <- optionMaybe lstr
name <- modNameParser
semi lexer
return (name, conv)
docDeclParser :: Parser (Doc, Decl)
docDeclParser = do
doc <- fmap (Doc . fromMaybe "") $ optionMaybe docComment
optional lspace
decl <- declParser
return $ (doc, decl)
declParser :: Parser Decl
declParser = mzero
<|> typeDeclParser
<|> tagDeclParser
<|> funDeclParser
typeDeclParser :: Parser Decl
typeDeclParser = do
reserved lexer "type"
name <- unameParser
llex $ char '='
typ <- typeOpaqueParser
semi lexer
return $ TypeDecl name typ
tagDeclParser :: Parser Decl
tagDeclParser = do
reserved lexer "tagname"
typ <- typeParser
semi lexer
return $ TagDecl typ
funDeclParser :: Parser Decl
funDeclParser = do
(name, typ) <- unameTypeParser
semi lexer
case typ of
(FunType func) -> return $ FunctionDecl name func
_ -> unexpected "Expected function type"
constDeclParser :: Parser Decl
constDeclParser = notSupported "Constant parsing"
globalDeclParser :: Parser Decl
globalDeclParser = notSupported "Global parsing"
typeOpaqueParser :: Parser (Maybe Type)
typeOpaqueParser = (opaqueParser >> return Nothing) <|> fmap Just typeParser
opaqueParser :: Parser ()
opaqueParser = reserved lexer "opaque" >> return ()
typeParser :: Parser Type
typeParser = do
typs <- typeStartParser
mods <- typeEndParser
return $ mods typs
typeStartParser :: Parser [(Maybe Name,Type)]
typeStartParser = mzero
<|> parenTypeParser
<|> (single.returnPair) <$> arrayTypeParser
<|> (single.returnPair) <$> enumTypeParser
<|> (single.returnPair) <$> unionTypeParser
<|> (single.returnPair) <$> structTypeParser
<|> (single.returnPair) <$> bitfieldTypeParser
<|> (single.returnPair) <$> primTypeParser
<|> (single.returnPair) <$> aliasTypeParser
returnPair x = (Nothing,x)
typeEndParser :: Parser ([(Maybe Name, Type)] -> Type)
typeEndParser = foldr comp noTypeEnd <$> many (ptr <|> func)
where
ptr = do
llex $ char '*'
return mkPtr
func = do
llex $ string "->"
typ <- typeParser
return $ mkFun typ
noTypeEnd :: [(Maybe Name, Type)] -> Type
noTypeEnd [(_,x)] = x
noTypeEnd _ = error "Unexpected argument head"
mkPtr :: [(Maybe Name, Type)] -> Type
mkPtr [(_,x)] = RefType . Pointer $ x
mkPtr _ = error "Unexpected argument head"
mkFun :: Type -> [(Maybe Name, Type)] -> Type
mkFun r as = FunType $ Function as r
comp :: ([(Maybe x,a)] -> b) -> ([(Maybe x,b)] -> c) -> [(Maybe x,a)] -> c
comp g f = f . single . returnPair . g
parenTypeParser :: Parser [(Maybe Name, Type)]
parenTypeParser = do
llex $char '('
types <- maybeNameTypeParser `sepBy` (llex $ char ',')
llex $char ')'
return $ types
arrayTypeParser :: Parser Type
arrayTypeParser = do
llex $ char '['
typ <- typeParser
llex $ char 'x'
n <- lnat
llex $ char ']'
return $ RefType $Array typ (fromInteger n)
enumTypeParser :: Parser Type
enumTypeParser = do
reserved lexer "enum"
llex $ char '{'
(n:ns) <- unameParser `sepBy` (llex $ char ',')
llex $ char '}'
return $ CompType $ Enum (n :| ns)
structTypeParser :: Parser Type
structTypeParser = do
reserved lexer "struct"
llex $ char '{'
(n:ns) <- unameTypeParser `sepBy1` (llex $ char ',')
llex $ char '}'
return $ CompType $ Struct (n :| ns)
unionTypeParser :: Parser Type
unionTypeParser = do
reserved lexer "union"
llex $ char '{'
(n:ns) <- unameTypeParser `sepBy1` (llex $ char ',')
llex $ char '}'
return $ CompType $ Union (n :| ns)
bitfieldTypeParser :: Parser Type
bitfieldTypeParser = do
reserved lexer "bitfield"
notSupported "Bitfield parsing"
primTypeParser :: Parser Type
primTypeParser = mzero
<|> "Int8" ==> Int8
<|> "Int16" ==> Int16
<|> "Int32" ==> Int32
<|> "Int64" ==> Int64
<|> "UInt8" ==> UInt8
<|> "UInt16" ==> UInt16
<|> "UInt32" ==> UInt32
<|> "UInt64" ==> UInt64
<|> "Bool" ==> Bool
<|> "Void" ==> Void
<|> "Size" ==> Size
<|> "Ptrdiff" ==> Ptrdiff
<|> "Intptr" ==> Intptr
<|> "UIntptr" ==> UIntptr
<|> "Char" ==> Char
<|> "Short" ==> Short
<|> "Int" ==> Int
<|> "Long" ==> Long
<|> "LongLong" ==> LongLong
<|> "UChar" ==> UChar
<|> "UShort" ==> UShort
<|> "UInt" ==> UInt
<|> "ULong" ==> ULong
<|> "ULongLong" ==> ULongLong
<|> "Float" ==> Float
<|> "Double" ==> Double
<|> "LongDouble" ==> LongDouble
where
s ==> t = lres s >> return (PrimType t)
aliasTypeParser :: Parser Type
aliasTypeParser = do
name <- nameParser
return $ AliasType name
docComment :: Parser String
docComment = do
string "/**"
manyTill anyChar (try (string "*/"))
nameParser :: Parser Name
nameParser = do
r <- identifier lexer `sepBy1` (string ".")
return $ case r of
[x] -> Name x
(x:xs) -> QName (ModuleName $ x :| init xs) (last xs)
unameParser :: Parser Name
unameParser = Name <$> lname
unameTypeParser :: Parser (Name, Type)
unameTypeParser = do
name <- unameParser
llex $ char ':'
typ <- typeParser
return $ (name, typ)
maybeNameTypeParser :: Parser (Maybe Name, Type)
maybeNameTypeParser = try (fmap (first Just) unameTypeParser) <|> fmap returnPair typeParser
occs p = length <$> many p
follow p q = do
a <- p
b <- q
return (a, b)
lexer :: TokenParser ()
lexer = makeTokenParser $ LanguageDef {
commentStart = "/*!",
commentEnd = "*/",
commentLine = "//",
nestedComments = True,
identStart = (letter <|> char '_'),
identLetter = (alphaNum <|> char '_'),
opStart = mzero,
opLetter = mzero,
reservedNames = reservedNames,
reservedOpNames = mzero,
caseSensitive = True
}
where
reservedNames = [
"module", "import", "type", "tagname", "opaque", "enum", "union", "struct", "bitfield",
"Int", "Void", "Size", "Ptrdiff", "Intptr", "UIntptr",
"Char", "Short", "Int", "Long", "LongLong",
"UChar", "UShort", "UInt", "ULong", "ULongLong",
"Float", "Double", "LongDouble",
"Int8", "Int16", "Int32", "Int64", "UInt8", "UInt16", "UInt32", "UInt64" ]
llex = lexeme lexer
lnat = natural lexer
lstr = stringLiteral lexer
lname = identifier lexer
lres = reserved lexer
lspace = whiteSpace lexer
single x = [x]
notSupported x = error $ "Not supported yet: " ++ x
eitherToMaybe (Right x) = Just x
eitherToMaybe (Left _) = Nothing