{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.VRML.Parser
( Parser (..)
, parseVRML
) where
import Data.VRML.Types
import GHC.Generics
import Data.Int
import Data.Void
import Control.Monad (void)
import Data.Char (isSpace)
import Data.Text hiding (empty)
import Text.Megaparsec
import Text.Megaparsec.Char as C
import Text.Megaparsec.Char.Lexer as L
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Text (putDoc)
type Parser = Parsec Void String
sc :: Parser ()
sc = L.space space1 (L.skipLineComment "#") empty
lexm :: Parser a -> Parser a
lexm = L.lexeme sc
space' :: Parser String
space' = some $ oneOf [' ', '\t']
space'' :: Parser String
space'' = many $ oneOf [' ', '\t']
parseVRML :: Parser VRML
parseVRML = do
version <- string "#" >> manyTill anySingle eol
values <- some parseStatement
return $ VRML version values
parseStatement :: Parser Statement
parseStatement =
(StRoute <$> parseRoute) <|>
(StNode <$> parseNodeStatement) <|>
(StProto <$> parseProtoStatement)
parseNodeStatement :: Parser NodeStatement
parseNodeStatement =
(DEF <$> (lstring "DEF" >> parseNodeNameId) <*> parseNode) <|>
(USE <$> (lstring "USE" >> parseNodeNameId)) <|>
(NodeStatement <$> parseNode)
parseProtoStatement :: Parser ProtoStatement
parseProtoStatement =
(id (Proto
<$> (lstring "PROTO" >> parseNodeTypeId)
<*> (lstring "[" >> many parseInterface <* lstring "]")
<*> (lstring "{" >> many parseProtoStatement)
<*> parseNode
<*> (many parseStatement <* lstring "}"))) <|>
(id (ExternProto
<$> (lstring "EXTERNPROTO" >> parseNodeTypeId)
<*> (lstring "[" >> many parseExternInterface <* lstring "]")
<*> parseURLList))
parseRestrictedInterface :: Parser RestrictedInterface
parseRestrictedInterface =
( RestrictedInterfaceEventIn <$> (lstring "eventIn" >> parseFieldType) <*> parseEventInId) <|>
( RestrictedInterfaceEventOut <$> (lstring "eventOut" >> parseFieldType) <*> parseEventOutId) <|>
( RestrictedInterfaceField <$> (lstring "field" >> parseFieldType) <*> parseFieldId <*> parseFieldValue)
parseInterface :: Parser Interface
parseInterface =
( InterfaceEventIn <$> (lstring "eventIn" >> parseFieldType) <*> parseEventInId) <|>
( InterfaceEventOut <$> (lstring "eventOut" >> parseFieldType) <*> parseEventOutId) <|>
( InterfaceField <$> (lstring "field" >> parseFieldType) <*> parseFieldId <*> parseFieldValue) <|>
( InterfaceExposedField <$> (lstring "exposedField" >> parseFieldType) <*> parseFieldId <*> parseFieldValue)
parseExternInterface :: Parser ExternInterface
parseExternInterface =
( ExternInterfaceEventIn <$> (lstring "eventIn" >> parseFieldType) <*> parseEventInId) <|>
( ExternInterfaceEventOut <$> (lstring "eventOut" >> parseFieldType) <*> parseEventOutId) <|>
( ExternInterfaceField <$> (lstring "field" >> parseFieldType) <*> parseFieldId) <|>
( ExternInterfaceExposedField <$> (lstring "exposedField" >> parseFieldType) <*> parseFieldId)
parseRoute :: Parser Route
parseRoute =
Route
<$> (lstring "ROUTE" >> parseNodeNameId)
<*> (lstring "." >> parseEventOutId)
<*> (lstring "TO" >> parseNodeNameId)
<*> (lstring "." >> parseEventInId)
parseURLList :: Parser URLList
parseURLList =
((\v -> URLList [v]) <$> stringLiteral) <|>
(URLList <$> (lstring "[" >> many stringLiteral <* lstring "]"))
parseNode :: Parser Node
parseNode = do
nid <- parseNodeTypeId
case nid of
(NodeTypeId "Script") -> do
_ <- lstring "{"
nbody <- many parseScriptBodyElement
_ <- lstring "}"
return $ Script nbody
_ -> do
_ <- lstring "{"
nbody <- many parseNodeBodyElement
_ <- lstring "}"
return $ Node nid nbody
parseScriptBodyElement :: Parser ScriptBodyElement
parseScriptBodyElement =
(SBEventIn <$> (lstring "eventIn" >> parseFieldType) <*> parseEventInId <*> (lstring "IS" >> parseEventInId) ) <|>
(SBEventOut <$> (lstring "eventOut" >> parseFieldType) <*> parseEventOutId <*> (lstring "IS" >> parseEventOutId) ) <|>
(SBFieldId <$> (lstring "field" >> parseFieldType) <*> parseFieldId <*> (lstring "IS" >> parseFieldId)) <|>
(SBRestrictedInterface <$> parseRestrictedInterface) <|>
(SBNode <$> parseNodeBodyElement)
parseNodeBodyElement :: Parser NodeBodyElement
parseNodeBodyElement =
(NBRoute <$> parseRoute) <|>
(NBProto <$> parseProtoStatement) <|>
(try $ (NBFieldId <$> parseFieldId <*> (lstring "IS" >> parseFieldId) )) <|>
(try $ (NBEventIn <$> parseEventInId <*> (lstring "IS" >> parseEventInId) )) <|>
(try $ (NBEventOut <$> parseEventOutId <*> (lstring "IS" >> parseEventOutId) )) <|>
(FV <$> parseFieldId <*> parseFieldValue)
parseNodeNameId :: Parser NodeNameId
parseNodeNameId = NodeNameId <$> identifier
parseNodeTypeId :: Parser NodeTypeId
parseNodeTypeId = NodeTypeId <$> identifier
parseFieldId :: Parser FieldId
parseFieldId = FieldId <$> identifier
parseEventInId :: Parser EventInId
parseEventInId = EventInId <$> identifier
parseEventOutId :: Parser EventOutId
parseEventOutId = EventOutId <$> identifier
rws :: [String]
rws = ["PROTO","DEF","USE"]
identifier :: Parser String
identifier = (lexm . try) (p >>= check)
where
p = (:) <$> (oneOf identStart) <*> many (oneOf identLetter)
check x = if x `elem` rws
then fail $ "keyword " ++ show x ++ " cannot be an identifier"
else return x
identStart :: [Char]
identStart = ['a'..'z'] ++ ['A'..'Z'] ++ ['_']
identLetter :: [Char]
identLetter = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9'] ++ [':', '<', '>']
lstring = lexm.string
parseFieldType :: Parser FieldType
parseFieldType
= (lstring "MFBool" >> pure MFBool)
<|> (lstring "MFColor" >> pure MFColor)
<|> (lstring "MFFloat" >> pure MFFloat)
<|> (lstring "MFString" >> pure MFString)
<|> (lstring "MFTime" >> pure MFTime)
<|> (lstring "MFVec2f" >> pure MFVec2f)
<|> (lstring "MFVec3f" >> pure MFVec3f)
<|> (lstring "MFNode" >> pure MFNode)
<|> (lstring "MFRotation" >> pure MFRotation)
<|> (lstring "MFInt32" >> pure MFInt32)
<|> (lstring "SFBool" >> pure SFBool)
<|> (lstring "SFColor" >> pure SFColor)
<|> (lstring "SFFloat" >> pure SFFloat)
<|> (lstring "SFImage" >> pure SFImage)
<|> (lstring "SFInt32" >> pure SFInt32)
<|> (lstring "SFNode" >> pure SFNode)
<|> (lstring "SFRotation" >> pure SFRotation)
<|> (lstring "SFString" >> pure SFString)
<|> (lstring "SFTime" >> pure SFTime)
<|> (lstring "SFVec2f" >> pure SFVec2f)
<|> (lstring "SFVec3f" >> pure SFVec3f)
parseFloat :: Parser Float
parseFloat =realToFrac <$> lexm pfloat
parseFloat' :: Parser Float
parseFloat' =realToFrac <$> pfloat
parseInt :: Parser Int32
parseInt = fromIntegral <$> lexm pinteger
tupleParser :: Parser (Float,Float)
tupleParser = (,) <$> parseFloat <*> parseFloat
parseFieldValue :: Parser FieldValue
parseFieldValue
= (Sbool <$> parseBool)
<|> (lstring "NULL" >> pure (Snode Nothing))
<|> (try $ Mrotation <$> parseArrayN ((,,,)
<$> parseFloat'
<*> (space'' >> parseFloat')
<*> (space'' >> parseFloat')
<*> (space'' >> parseFloat')))
<|> (try $ Mvec3f <$> parseArrayN ((,,)
<$> parseFloat'
<*> (space'' >> parseFloat')
<*> (space'' >> parseFloat')))
<|> (try $ Mvec2f <$> parseArrayN ((,)
<$> parseFloat'
<*> (space'' >> parseFloat')))
<|> (try $ Mfloat <$> parseArrayN parseFloat')
<|> (try $ Mbool <$> parseArray' parseBool)
<|> (try $ Mnode <$> parseArray' parseNodeStatement)
<|> (try $ Mstring <$> parseArray' stringLiteral)
<|> (try $ Mrotation <$> parseArray ((,,,) <$> parseFloat <*> parseFloat <*> parseFloat <*> parseFloat))
<|> (try $ Mvec3f <$> parseArray ((,,) <$> parseFloat <*> parseFloat <*> parseFloat))
<|> (try $ Mvec2f <$> parseArray ((,) <$> parseFloat <*> parseFloat))
<|> (try $ Mfloat <$> parseArray parseFloat)
<|> (try $ Mstring <$> parseArray stringLiteral)
<|> (try $ Mbool <$> parseArray parseBool)
<|> (try $ (\a b c d -> Srotation (a,b,c,d)) <$> parseFloat <*> parseFloat <*> parseFloat <*> parseFloat)
<|> (try $ (\a b c -> Svec3f (a,b,c)) <$> parseFloat <*> parseFloat <*> parseFloat)
<|> (try $ (\a b -> Svec2f (a,b)) <$> parseFloat <*> parseFloat)
<|> (try $ (Sfloat <$> parseFloat))
<|> (try $ (Sstring <$> stringLiteral))
<|> (try $ (Snode . Just <$> parseNodeStatement))
parseArray :: Parser a -> Parser [a]
parseArray parser = do
_ <- lstring "["
values <- parser `sepBy` lstring ","
_ <- lstring "]"
return values
parseArrayN :: Parser a -> Parser [a]
parseArrayN parser = do
_ <- lstring "["
values <- some (try (space'' >> parser >>= \v -> space'' >> eol >> pure v))
_ <- space'' >> lstring "]"
return values
parseArray' :: Parser a -> Parser [a]
parseArray' parser = do
_ <- lstring "["
values <- many parser
_ <- lstring "]"
return values
parseBool :: Parser Bool
parseBool
= (lstring "TRUE" >> pure True)
<|> (lstring "FALSE" >> pure False)
pinteger :: Parser Integer
pinteger =
(try L.hexadecimal) <|>
(L.decimal) <|>
((string "-") >> (try L.hexadecimal <|> L.decimal) >>= \v -> pure (-v))
pfloat :: Parser Float
pfloat =
(realToFrac <$> L.scientific) <|>
((string "-") >> L.scientific >>= \v -> realToFrac <$> (pure (-v)))
stringLiteral :: Parser String
stringLiteral = lexm $ char '\"' *> manyTill charLiteral (char '\"')