packages feed

VRML (empty) → 0.1.0.0

raw patch · 15 files changed

+1701/−0 lines, 15 filesdep +VRMLdep +aesondep +basesetup-changed

Dependencies added: VRML, aeson, base, doctest, megaparsec, pretty-simple, prettyprinter, text

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for VRML++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright 2020 Junji Hashimoto++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,35 @@+# VRML++VRML is a text file format for a 3D polygon.+It is a standard known as ISO/IEC 14772-1:1997.+It has been superseded by X3D.++[webots](https://cyberbotics.com/) uses VRML-format to make simulation environment.+This package is developed for making the environment by haskell.++# VRML to Haskell++vrml2haskell command generates haskell-code from VRML-file.+Usage is below.++```+> vrml2haskell "vrml file" > "haskell file"+```++# Haskell to VRML++'ToNode' type-class makes VRML-data from Haskell-data with deriving ToNode.++```+class ToNode a where+  toNode :: NodeLike b => a -> b+```++Usage of deriving ToNode is below.++```+data Box = Box+  { size :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ VRML.cabal view
@@ -0,0 +1,114 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9f7a366a403e09e7f1211dbcf2e41b3610439f1b4ef03f7fc750431db2f80bf9++name:           VRML+version:        0.1.0.0+synopsis:       VRML parser and generator for Haskell+description:    Please see the README on GitHub at https://github.com/junjihashimoto/VRML#readme+category:       Graphics+homepage:       https://github.com/junjihashimoto/VRML#readme+bug-reports:    https://github.com/junjihashimoto/VRML/issues+author:         Junji Hashimoto+maintainer:     junji.hashimoto@gmail.com+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/junjihashimoto/VRML++library+  exposed-modules:+      Data.VRML+      Data.VRML.Nodes+      Data.VRML.Parser+      Data.VRML.Proto+      Data.VRML.Text+      Data.VRML.Types+  other-modules:+      Paths_VRML+  hs-source-dirs:+      src+  build-depends:+      aeson+    , base >=4.7 && <5+    , megaparsec+    , prettyprinter+    , text+  default-language: Haskell2010++executable vrml2haskell+  main-is: vrml2haskell.hs+  other-modules:+      Paths_VRML+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      VRML+    , aeson+    , base >=4.7 && <5+    , megaparsec+    , pretty-simple >=3.0.0.0+    , prettyprinter+    , text+  default-language: Haskell2010++executable vrmlfmt+  main-is: vrmlfmt.hs+  other-modules:+      Paths_VRML+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      VRML+    , aeson+    , base >=4.7 && <5+    , megaparsec+    , prettyprinter+    , text+  default-language: Haskell2010++executable vrmlproto2haskell+  main-is: vrmlproto2haskell.hs+  other-modules:+      Paths_VRML+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      VRML+    , aeson+    , base >=4.7 && <5+    , megaparsec+    , prettyprinter+    , text+  default-language: Haskell2010++test-suite doctest+  type: exitcode-stdio-1.0+  main-is: doctests.hs+  other-modules:+      Paths_VRML+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      VRML+    , aeson+    , base >=4.7 && <5+    , doctest+    , megaparsec+    , prettyprinter+    , text+  default-language: Haskell2010
+ app/vrml2haskell.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.VRML+import System.Environment+import Text.Pretty.Simple+import Text.Pretty.Simple.Internal.OutputPrinter+import Text.Megaparsec+import Control.Monad (void)+  +myPrint =+  pPrintOpt+  NoCheckColorTty+  ( OutputOptions+    { outputOptionsIndentAmount = 2+    , outputOptionsColorOptions = Nothing+    , outputOptionsEscapeNonPrintable = True+    }+  )++main :: IO ()+main = do+  args <- getArgs+  f <- readFile (head args)+  case parse parseVRML "" f of+    Right v -> myPrint v+    Left _ -> void $ parseTest parseVRML f
+ app/vrmlfmt.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.VRML+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Text (putDoc)+import System.Environment+import Text.Megaparsec+import Control.Monad (void)+  +main :: IO ()+main = do+  args <- getArgs+  f <- readFile (head args)+  case parse parseVRML "" f of+    Right v -> putDoc $ pretty v+    Left _ -> void $ parseTest parseVRML f
+ app/vrmlproto2haskell.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.VRML.Types+import Data.VRML.Parser+import Data.VRML.Proto+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Text (putDoc)+import System.Environment+import Text.Megaparsec+import Control.Monad (void)+  +main :: IO ()+main = do+  args <- getArgs+  f <- readFile (head args)+  case parse parseVRML "" f of+    Right v -> putDoc $ pretty v+    Left _ -> void $ parseTest parseVRML f
+ src/Data/VRML.hs view
@@ -0,0 +1,8 @@+module Data.VRML+  ( module Data.VRML.Types+  , module Data.VRML.Parser+  , module Data.VRML.Text+) where+import Data.VRML.Types+import Data.VRML.Parser+import Data.VRML.Text
+ src/Data/VRML/Nodes.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DeriveAnyClass #-}++module Data.VRML.Nodes where+import Data.VRML.Types+import GHC.Generics+import Data.Int++data Anchor = Anchor+  { children :: [Node]+  , description :: String+  , parameter :: [String]+  , url :: [String]+  , bboxCenter :: (Float,Float,Float)+  , bboxSize :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data Appearance = Appearance+  { material :: Maybe Node+  , texture :: Maybe Node+  , textureTransform :: Maybe Node+  } deriving (Generic,Show,Eq,ToNode)++data AudioClip = AudioClip+  { description :: String+  , loop :: Bool+  , pitch :: Float+  , startTime :: Time+  , stopTime :: Time+  , url :: [String]+  } deriving (Generic,Show,Eq,ToNode)++data Billboard = Billboard+  { axisOfRotation :: (Float,Float,Float)+  , children :: [Node]+  , bboxCenter :: (Float,Float,Float)+  , bboxSize :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data Box = Box+  { size :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data Collision = Collision+  { children :: [Node]+  , collide :: Bool+  , bboxCenter :: (Float,Float,Float)+  , bboxSize :: (Float,Float,Float)+  , proxy :: Maybe Node+  } deriving (Generic,Show,Eq,ToNode)++{-+data Color' = Color'+  { color :: [Color]+  } deriving (Generic,Show,Eq,ToNode)+-}++data ColorInterpolator = ColorInterpolator+  { key :: [Float]+  , keyValue :: [Color]+  } deriving (Generic,Show,Eq,ToNode)++data Cone = Cone+  { bottomRadius :: Float+  , height :: Float+  , side :: Bool+  , bottom :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data Coordinate = Coordinate+  { point :: [(Float,Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)++data CoordinateInterpolator = CoordinateInterpolator+  { key :: [Float]+  , keyValue :: [(Float,Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)++data Cylinder = Cylinder+  { bottom :: Bool+  , height :: Float+  , radius :: Float+  , side :: Bool+  , top :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data CylinderSensor = CylinderSensor+  { autoOffset :: Bool+  , diskAngle :: Float+  , enabled :: Bool+  , maxAngle :: Float+  , minAngle :: Float+  , offset :: Float+  } deriving (Generic,Show,Eq,ToNode)++data DirectionalLight = DirectionalLight+  { ambientIntensity :: Float+  , color :: Color+  , direction :: (Float,Float,Float)+  , intensity :: Float+  , on :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data ElevationGrid = ElevationGrid+  { color :: Maybe Node+  , normal :: Maybe Node+  , texCoord :: Maybe Node+  , height :: [Float]+  , ccw :: Bool+  , colorPerVertex :: Bool+  , creaseAngle :: Float+  , normalPerVertex :: Bool+  , solid :: Bool+  , xDimension :: Int32+  , xSpacing :: Float+  , zDimension :: Int32+  , zSpacing :: Float+  } deriving (Generic,Show,Eq,ToNode)++data Extrusion = Extrusion+  { beginCap :: Bool+  , ccw :: Bool+  , convex :: Bool+  , creaseAngle :: Float+  , crossSection :: [(Float,Float)]+  , endCap :: Bool+  , orientation :: [(Float,Float,Float,Float)]+  , scale :: [(Float,Float)]+  , solid :: Bool+  , spine :: [(Float,Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)++data Fog = Fog+  { color :: Color+  , fogType :: String+  , visibilityRange :: Float+  } deriving (Generic,Show,Eq,ToNode)++data FontStyle = FontStyle+  { family :: String+  , horizontal :: Bool+  , justify :: [String]+  , language :: String+  , leftToRight :: Bool+  , size :: Float+  , spacing :: Float+  , style :: String+  , topToBottom :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data Group = Group+  { children :: [Node]+  , bboxCenter :: (Float,Float,Float)+  , bboxSize :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data ImageTexture = ImageTexture+  { url :: [String]+  , repeatS :: Bool+  , repeatT :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data IndexedFaceSet = IndexedFaceSet+  { color :: Maybe Node+  , coord :: Maybe Node+  , normal :: Maybe Node+  , texCoord :: Maybe Node+  , ccw :: Bool+  , colorIndex :: [Int32]+  , colorPerVertex :: Bool+  , convex :: Bool+  , coordIndex :: [Int32]+  , creaseAngle :: Float+  , normalIndex :: [Int32]+  , normalPerVertex :: Bool+  , solid :: Bool+  , texCoordIndex :: [Int32]+  } deriving (Generic,Show,Eq,ToNode)++data IndexedLineSet = IndexedLineSet+  { color :: Maybe Node+  , coord :: Maybe Node+  , colorIndex :: [Int32]+  , colorPerVertex :: Bool+  , coordIndex :: [Int32]+  } deriving (Generic,Show,Eq,ToNode)++data Inline = Inline+  { url :: [String]+  , bboxCenter :: (Float,Float,Float)+  , bboxSize :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data LOD = LOD+  { level :: [Node]+  , center :: (Float,Float,Float)+  , range :: [Float]+  } deriving (Generic,Show,Eq,ToNode)++data Material = Material+  { ambientIntensity :: Float+  , diffuseColor :: Color+  , emissiveColor :: Color+  , shininess :: Float+  , specularColor :: Color+  , transparency :: Float+  } deriving (Generic,Show,Eq,ToNode)++data MovieTexture = MovieTexture+  { loop :: Bool+  , speed :: Float+  , startTime :: Time+  , stopTime :: Time+  , url :: [String]+  , repeatS :: Bool+  , repeatT :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data NavigationInfo = NavigationInfo+  { avatarSize :: [Float]+  , headlight :: Bool+  , speed :: Float+--  , type :: [String]+  , visibilityLimit :: Float+  } deriving (Generic,Show,Eq,ToNode)++data Normal = Normal+  { vector :: [(Float,Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)+++data NormalInterpolator = NormalInterpolator+  { key :: [Float]+  , keyValue :: [(Float,Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)++data OrientationInterpolator = OrientationInterpolator+  { key :: [Float]+  , keyValue :: [(Float,Float,Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)++data PixelTexture = PixelTexture+  { image :: [Int32]+  , repeatS :: Bool+  , repeatT :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data PlaneSensor = PlaneSensor+  { autoOffset :: Bool+  , enabled :: Bool+  , maxPosition :: (Float,Float)+  , minPosition :: (Float,Float)+  , offset :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data PointLight = PointLight+  { ambientIntensity :: Float+  , attenuation :: (Float,Float,Float)+  , color :: Color+  , intensity :: Float+  , location :: (Float,Float,Float)+  , on :: Bool+  , radius :: Float+  } deriving (Generic,Show,Eq,ToNode)++data PointSet = PointSet+  { color :: Maybe Node+  , coord :: Maybe Node+  } deriving (Generic,Show,Eq,ToNode)++data PositionInterpolator = PositionInterpolator+  { key :: [Float]+  , keyValue :: [(Float,Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)++data ProximitySensor = ProximitySensor+  { center :: (Float,Float,Float)+  , size :: (Float,Float,Float)+  , enabled :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data ScalarInterpolator = ScalarInterpolator+  { key :: [Float]+  , keyValue :: [Float]+  } deriving (Generic,Show,Eq,ToNode)++data Shape = Shape+  { appearance :: Maybe Node+  , geometry :: Maybe Node+  } deriving (Generic,Show,Eq,ToNode)++data Sound = Sound+  { direction :: (Float,Float,Float)+  , intensity :: Float+  , location :: (Float,Float,Float)+  , maxBack :: Float+  , maxFront :: Float+  , minBack :: Float+  , minFront :: Float+  , priority :: Float+  , source :: Maybe Node+  , spatialize :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data Sphere = Sphere+  { radius :: Float+  } deriving (Generic,Show,Eq,ToNode)++data SphereSensor = SphereSensor+  { autoOffset :: Bool+  , enabled :: Bool+  , offset :: (Float,Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data SpotLight = SpotLight+  { ambientIntensity :: Float+  , attenuation :: (Float,Float,Float)+  , beamWidth :: Float+  , color :: Color+  , cutOffAngle :: Float+  , direction :: (Float,Float,Float)+  , intensity :: Float+  , location :: (Float,Float,Float)+  , on :: Bool+  , radius :: Float+  } deriving (Generic,Show,Eq,ToNode)++data Switch = Switch+  { choice :: [Node]+  , whichChoice :: Int32+  } deriving (Generic,Show,Eq,ToNode)++data Text = Text+  { string :: [String]+  , fontStyle :: Maybe Node+  , length :: [Float]+  , maxExtent :: Float+  } deriving (Generic,Show,Eq,ToNode)++data TextureCoordinate = TextureCoordinate+  { point :: [(Float,Float)]+  } deriving (Generic,Show,Eq,ToNode)++data TextureTransform = TextureTransform+  { center :: (Float,Float)+  , rotation :: Float+  , scale :: (Float,Float)+  , translation :: (Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data TimeSensor = TimeSensor+  { cycleInterval :: Time+  , enabled :: Bool+  , loop :: Bool+  , startTime :: Time+  , stopTime :: Time+  } deriving (Generic,Show,Eq,ToNode)++data TouchSensor = TouchSensor+  { enabled :: Bool+  } deriving (Generic,Show,Eq,ToNode)++data Transform = Transform+  { center :: (Float,Float,Float)+  , children :: [Node]+  , rotation :: (Float,Float,Float,Float)+  , scale :: (Float,Float,Float)+  , scaleOrientation :: (Float,Float,Float,Float)+  , translation :: (Float,Float,Float)+  , bboxCenter :: (Float,Float,Float)+  , bboxSize :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data Viewpoint = Viewpoint+  { fieldOfView :: Float+  , jump :: Bool+  , orientation :: (Float,Float,Float,Float)+  , position :: (Float,Float,Float)+  , description :: String+  } deriving (Generic,Show,Eq,ToNode)++data VisibilitySensor = VisibilitySensor+  { center :: (Float,Float,Float)+  , enabled :: Bool+  , size :: (Float,Float,Float)+  } deriving (Generic,Show,Eq,ToNode)++data WorldInfo = WorldInfo+  { info :: [String]+  , title :: String+  } deriving (Generic,Show,Eq,ToNode)+
+ src/Data/VRML/Parser.hs view
@@ -0,0 +1,361 @@+{-# 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' = void $ takeWhileP (Just "white space") $ \t -> do+space' :: Parser String+space' = some $ oneOf [' ', '\t']++space'' :: Parser String+space'' = many $ oneOf [' ', '\t']++-- | parser of VRML+--+-- >>> parseTest parseVRML "#VRML_SIM R2020a utf8\nUSE hoge1"+-- VRML {version = "VRML_SIM R2020a utf8", statements = [StNode (USE (NodeNameId "hoge1"))]}+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)++-- | parser of Node+--+-- >>> parseTest parseNodeStatement "hoge {}"+-- NodeStatement (Node "hoge" [])+-- >>> parseTest parseNodeStatement "DEF hoge1 hoge {}"+-- DEF (NodeNameId "hoge1") (Node "hoge" [])+-- >>> parseTest parseNodeStatement "USE hoge1"+-- USE (NodeNameId "hoge1")+parseNodeStatement :: Parser NodeStatement+parseNodeStatement = +  (DEF <$> (lstring "DEF" >> parseNodeNameId) <*> parseNode) <|>+  (USE <$> (lstring "USE" >> parseNodeNameId)) <|>+  (NodeStatement <$> parseNode)++-- | parser of Proto+--+-- >>> parseTest parseProtoStatement "PROTO Cube [] { Box {} }"+-- Proto "Cube" [] [] (Node "Box" []) []+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)++-- | parser of Route+--+-- >>> parseTest parseRoute "ROUTE hoge.hoge TO hoge.hoge"+-- Route (NodeNameId "hoge") (EventOutId "hoge") (NodeNameId "hoge") (EventInId "hoge")+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 "]"))++-- | parser of Node+--+-- >>> parseTest parseNode "hoge {hoge 1 hoge 2}"+-- Node "hoge" [FV "hoge" (Sfloat 1.0),FV "hoge" (Sfloat 2.0)]+-- >>> parseTest parseNode "BmwX5 { translation -78.7 0.4 7.53 }"+-- Node "BmwX5" [FV "translation" (Svec3f (-78.7,0.4,7.53))]+-- >>> parseTest parseNode "BmwX5 { rotation 0 1 0 1.5708}"+-- Node "BmwX5" [FV "rotation" (Srotation (0.0,1.0,0.0,1.5708))]+-- >>> parseTest parseNode "BmwX5 { controller \"autonomous_vehicle\" }"+-- Node "BmwX5" [FV "controller" (Sstring "autonomous_vehicle")]+-- >>> parseTest parseNode "BmwX5 { translation -78.7 0.4 7.53  rotation 0 1 0 1.5708 controller \"autonomous_vehicle\" }"+-- Node "BmwX5" [FV "translation" (Svec3f (-78.7,0.4,7.53)),FV "rotation" (Srotation (0.0,1.0,0.0,1.5708)),FV "controller" (Sstring "autonomous_vehicle")]+-- >>> parseTest parseNode "Script {}"+-- Script []+-- >>> parseTest parseNode "Script {  }"+-- Script []+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)++-- >>> parseTest parseBodyElement "maxPosition 1e4 1e4"+-- FV "maxPosition" (Svec2f (1e4,1e4))+-- >>> parseTest parseBodyElement "width IS width"+-- NBFieldId "width" "width"+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"]++-- | parser of Id+--+-- >>> parseTest identifier "hogehoge"+-- "hogehoge"+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++-- | parser of FieldType+--+-- >>> parseTest parseFieldType "MFColor"+-- MFColor+-- >>> parseTest parseFieldType "MFString"+-- MFString+-- >>> parseTest parseFieldType "SFColor"+-- SFColor+-- >>> parseTest parseFieldType "MFColor "+-- MFColor+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++-- | parser of FieldType+--+-- >>> parseTest tupleParser "1e4 1e4"+-- (10000.0,10000.0)+tupleParser :: Parser (Float,Float)+tupleParser = (,) <$> parseFloat <*> parseFloat++-- | parser of FieldType+--+-- >>> parseTest parseFieldValue "TRUE"+-- Sbool True+-- >>> parseTest parseFieldValue "FALSE"+-- Sbool False+-- >>> parseTest parseFieldValue "NULL"+-- Snode Nothing+-- >>> parseTest parseFieldValue "\"hoge\\\"hoge\""+-- Sstring "hoge\"hoge"+-- >>> parseTest parseFieldValue "\"autonomous_vehicle\""+-- Sstring "autonomous_vehicle"+-- >>> parseTest parseFieldValue "1e4 1e4"+-- Svec2f (10000.0,10000.0)+-- >>> parseTest parseFieldValue "[1e4 1e4 1e4,1e4 1e4 1e4]"+-- Mvec3f [(10000.0,10000.0,10000.0),(10000.0,10000.0,10000.0)]+-- >>> parseTest parseFieldValue "[\n1e4 1e4\n1e4 1e4\n]"+-- Mvec2f [(10000.0,10000.0),(10000.0,10000.0)]+-- >>> parseTest parseFieldValue "[\n1e4 1e4 1e4\n1e4 1e4 1e4\n]"+-- Mvec3f [(10000.0,10000.0,10000.0),(10000.0,10000.0,10000.0)]+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)))++-- | parser of FieldType+--+-- >>> parseTest stringLiteral "\"hoge\\\"hoge\""+-- "hoge\"hoge"+-- >>> parseTest stringLiteral "\"autonomous_vehicle\""+-- "autonomous_vehicle"+stringLiteral :: Parser String+stringLiteral = lexm $ char '\"' *> manyTill charLiteral (char '\"')
+ src/Data/VRML/Proto.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.VRML.Proto 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, foldl, map)+import qualified Data.Text.Lazy.IO as TL+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++indent' = indent 2++instance Pretty VRML where+  pretty (VRML _ statements) =+    vsep (map pretty statements)  <> line++instance Pretty Statement where+  pretty (StNode v) = ""+  pretty (StProto v) = pretty v+  pretty (StRoute v) = ""++instance Pretty NodeStatement where+  pretty (DEF nodeNameId node) = ""+  pretty (USE nodeNameId) = ""+  pretty (NodeStatement node) = ""++instance Pretty ProtoStatement where+  pretty (Proto nodeTypeId [] _ _ _) =+    vsep+    [ "data" <+> pretty nodeTypeId <+> "=" <+> pretty nodeTypeId <+> "deriving (Generic,Show,Eq,ToNode)"+    ] <> line+  pretty (Proto nodeTypeId (interface:interfaces) _ _ _) =+    vsep+    [ "data" <+> pretty nodeTypeId <+> "=" <+> pretty nodeTypeId+    , indent' ("{" <+> pretty interface)+    , indent' (vsep (map (\i -> "," <+> pretty i) interfaces))+    , indent' ("}" <+> "deriving (Generic,Show,Eq,ToNode)")+    ] <> line+  pretty (ExternProto nodeTypeId interfaces _) = ""+++instance Pretty RestrictedInterface where+  pretty (RestrictedInterfaceEventIn ft ei) = ""+  pretty (RestrictedInterfaceEventOut ft eo) = ""+  pretty (RestrictedInterfaceField ft fi fv) =+    pretty fi <+> "::" <+> pretty ft++instance Pretty Interface where+  pretty (InterfaceEventIn ft ei) = ""+  pretty (InterfaceEventOut ft eo) = ""+  pretty (InterfaceField ft fi fv) =+    pretty fi <+> "::" <+> pretty ft+  pretty (InterfaceExposedField ft fi fv) =+    pretty fi <+> "::" <+> pretty ft++instance Pretty  ExternInterface where+  pretty (ExternInterfaceEventIn ft ei) = ""+  pretty (ExternInterfaceEventOut ft eo) = ""+  pretty (ExternInterfaceField ft fi) =+    pretty fi <+> "::" <+> pretty ft+  pretty (ExternInterfaceExposedField ft fi) =+    pretty fi <+> "::" <+> pretty ft++instance Pretty Route where+  pretty (Route nidOut eo nidIn ei) = ""++instance Pretty URLList where+  pretty (URLList urls) = ""++instance Pretty Node where+  pretty _ = ""++instance Pretty ScriptBodyElement where+  pretty _ = ""++instance Pretty NodeBodyElement where+  pretty _ = ""++instance Pretty NodeNameId where+  pretty (NodeNameId str) = pretty str++instance Pretty NodeTypeId where+  pretty (NodeTypeId str) = pretty str++instance Pretty FieldId where+  pretty (FieldId str) = pretty str++instance Pretty EventInId where+  pretty (EventInId str) = pretty str++instance Pretty EventOutId where+  pretty (EventOutId str) = pretty str++instance Pretty FieldType where+  pretty MFNode = "[Node]"+  pretty MFBool = "[Bool]"+  pretty MFColor = "[Color]"+  pretty MFFloat = "[Float]"+  pretty MFString = "[String]"+  pretty MFTime = "[Time]"+  pretty MFVec2f = "[(Float,Float)]"+  pretty MFVec3f = "[(Float,Float,Float)]"+  pretty MFInt32 = "[Int32]"+  pretty MFRotation = "[(Float,Float,Float,Float)]"+  pretty SFBool = "Bool"+  pretty SFColor = "Color"+  pretty SFFloat = "Float"+  pretty SFImage = "[Int32]"+  pretty SFInt32 = "Int32"+  pretty SFNode = "Maybe Node"+  pretty SFRotation = "(Float,Float,Float,Float)"+  pretty SFString = "String"+  pretty SFTime = "Time"+  pretty SFVec2f = "(Float,Float)"+  pretty SFVec3f = "(Float,Float,Float)"++instance Pretty FieldValue where+  pretty _ = ""++writeHaskell :: FilePath -> VRML ->  IO ()+writeHaskell filename doc =+  TL.writeFile filename $ renderLazy $ layoutPretty defaultLayoutOptions (pretty doc)
+ src/Data/VRML/Text.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.VRML.Text 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, foldl, map)+import qualified Data.Text.Lazy.IO as TL+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++indent' = indent 2++instance Pretty VRML where+  pretty (VRML version statements) =+    header  <> vsep (map pretty statements)  <> line+    where+      header = "#" <> pretty version <> line++instance Pretty Statement where+  pretty (StNode v) = pretty v+  pretty (StProto v) = pretty v+  pretty (StRoute v) = pretty v++instance Pretty NodeStatement where+  pretty (DEF nodeNameId node) = "DEF" <+> pretty nodeNameId <+> pretty node+  pretty (USE nodeNameId) = "USE" <+> pretty nodeNameId+  pretty (NodeStatement node) = pretty node++instance Pretty ProtoStatement where+  pretty (Proto nodeTypeId interfaces ps node st) =+    vsep+    [ "PROTO" <+> pretty nodeTypeId <+> "["+    ,  indent' (vsep (map pretty interfaces))+    , "]"+    , "{"+    , indent'+      (vsep (+          (map (\v -> pretty v <> line ) ps) ++ +            [pretty node] +++            (map (\v -> pretty v <> line ) st)+          ))+    , "}"+    ]+  pretty (ExternProto nodeTypeId interfaces urllist) =+    vsep+    [ "EXTERNPROTO" <+> pretty nodeTypeId <+> "["+    ,  indent' (vsep (map pretty interfaces))+    , "]"+    , pretty urllist+    ]++instance Pretty RestrictedInterface where+  pretty (RestrictedInterfaceEventIn ft ei) =+    "eventIn" <+> pretty ft <+> pretty ei+  pretty (RestrictedInterfaceEventOut ft eo) =+    "eventOut" <+> pretty ft <+> pretty eo+  pretty (RestrictedInterfaceField ft fi fv) =+    "field" <+> pretty ft <+> pretty fi <+> pretty fv++instance Pretty Interface where+  pretty (InterfaceEventIn ft ei) =+    "eventIn" <+> pretty ft <+> pretty ei+  pretty (InterfaceEventOut ft eo) =+    "eventOut" <+> pretty ft <+> pretty eo+  pretty (InterfaceField ft fi fv) =+    "field" <+> pretty ft <+> pretty fi <+> pretty fv+  pretty (InterfaceExposedField ft fi fv) =+    "exposedField" <+> pretty ft <+> pretty fi <+> pretty fv++instance Pretty  ExternInterface where+  pretty (ExternInterfaceEventIn ft ei) =+    "eventIn" <+> pretty ft <+> pretty ei+  pretty (ExternInterfaceEventOut ft eo) =+    "eventOut" <+> pretty ft <+> pretty eo+  pretty (ExternInterfaceField ft fi) =+    "field" <+> pretty ft <+> pretty fi+  pretty (ExternInterfaceExposedField ft fi) =+    "exposedField" <+> pretty ft <+> pretty fi++instance Pretty Route where+  pretty (Route nidOut eo nidIn ei) =+    "ROUTE" <+> pretty nidOut <> "." <> pretty eo <+> pretty nidIn <> "." <> pretty ei++instance Pretty URLList where+  pretty (URLList urls) =+    vsep+    [ "["+    , indent' (vsep (map (\url -> pretty (Sstring url) <> line) urls))+    , "]"+    ]++instance Pretty Node where+  pretty (Node ntypeid bodys) =+    vsep+    [ pretty ntypeid <+> "{"+    , indent' (vsep (map (\v -> pretty v) bodys))+    , "}"+    ]+  pretty (Script bodys) =+    vsep+    [ "Script" <+> "{"+    , indent' (vsep (map (\v -> pretty v) bodys))+    , "}"+    ]++instance Pretty ScriptBodyElement where+  pretty (SBNode v) = pretty v+  pretty (SBRestrictedInterface v) = pretty v+  pretty (SBEventIn etype eid1 eid2) = "eventIn" <+> pretty etype <+> pretty eid1 <+> "IS" <+>pretty eid2+  pretty (SBEventOut etype eid1 eid2) = "eventOut" <+> pretty etype <+> pretty eid1 <+> "IS" <+>pretty eid2+  pretty (SBFieldId etype eid1 eid2) = "field" <+> pretty etype <+> pretty eid1 <+> "IS" <+>pretty eid2++instance Pretty NodeBodyElement where+  pretty (FV fid fv) = pretty fid <+> pretty fv+  pretty (NBFieldId fid1 fid2) = pretty fid1 <+> pretty fid2+  pretty (NBEventIn eid1 eid2) = pretty eid1 <+> "IS" <+>pretty eid2+  pretty (NBEventOut eid1 eid2) = pretty eid1 <+> "IS" <+>pretty eid2+  pretty (NBRoute r) = pretty r+  pretty (NBProto p) = pretty p ++instance Pretty NodeNameId where+  pretty (NodeNameId str) = pretty str++instance Pretty NodeTypeId where+  pretty (NodeTypeId str) = pretty str++instance Pretty FieldId where+  pretty (FieldId str) = pretty str++instance Pretty EventInId where+  pretty (EventInId str) = pretty str++instance Pretty EventOutId where+  pretty (EventOutId str) = pretty str++instance Pretty FieldType where+  pretty MFBool = "MFBool"+  pretty MFColor = "MFColor"+  pretty MFFloat = "MFFloat"+  pretty MFString = "MFString"+  pretty MFTime = "MFTime"+  pretty MFVec2f = "MFVec2f"+  pretty MFVec3f = "MFVec3f"+  pretty SFBool = "SFBool"+  pretty SFColor = "SFColor"+  pretty SFFloat = "SFFloat"+  pretty SFImage = "SFImage"+  pretty SFInt32 = "SFInt32"+  pretty SFNode = "SFNode"+  pretty SFRotation = "SFRotation"+  pretty SFString = "SFString"+  pretty SFTime = "SFTime"+  pretty SFVec2f = "SFVec2f"+  pretty SFVec3f = "SFVec3f"++instance Pretty FieldValue where+  pretty (Sbool True) = "TRUE"+  pretty (Sbool False) = "FALSE"+  pretty (Scolor (Color (v1,v2,v3))) = pretty v1 <+> pretty v2 <+> pretty v3+  pretty (Sfloat v) = pretty v+  pretty (Simage v) = foldl (<+>) "[" (map pretty v) <+> "]"+  pretty (Sint32 v) = pretty v+  pretty (Snode (Just v)) = pretty v+  pretty (Snode Nothing) = "NULL"+  pretty (Srotation (v1,v2,v3,v4)) = pretty v1 <+> pretty v2 <+> pretty v3 <+> pretty v4+  pretty (Sstring v) =+    let rep [] = []+        rep ('"' : xs) = '\\' : '"' : rep xs+        rep (x : xs) = x : rep xs+    in "\"" <> pretty(rep v) <> "\"" ++  pretty (Stime (Time v)) = pretty v+  pretty (Svec2f (v1,v2)) = pretty v1 <+> pretty v2+  pretty (Svec3f (v1,v2,v3)) = pretty v1 <+> pretty v2 <+> pretty v3+  pretty (Mbool vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Sbool v)) vs))+    , "]"+    ]+  pretty (Mcolor vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Scolor v)) vs))+    , "]"+    ]+  pretty (Mfloat vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Sfloat v)) vs))+    , "]"+    ]+  pretty (Mint32 vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Sint32 v)) vs))+    , "]"+    ]+  pretty (Mnode vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Snode (Just v))) vs))+    , "]"+    ]+  pretty (Mrotation vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Srotation v)) vs))+    , "]"+    ]+  pretty (Mstring vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Sstring v)) vs))+    , "]"+    ]+  pretty (Mtime vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Stime v)) vs))+    , "]"+    ]+  pretty (Mvec2f vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Svec2f v)) vs))+    , "]"+    ]+  pretty (Mvec3f vs) =+    vsep+    [ "["+    , indent' (vsep (map (\v -> pretty (Svec3f v)) vs))+    , "]"+    ]+++writeVRML :: FilePath -> VRML ->  IO ()+writeVRML filename doc =+  TL.writeFile filename $ renderLazy $ layoutPretty defaultLayoutOptions (pretty doc)
+ src/Data/VRML/Types.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Data.VRML.Types where++import GHC.Generics+import Data.Int+import Data.String++data VRML = VRML+  { version :: String+  , statements :: [Statement]+  }+  deriving (Generic,Show,Eq)++data Statement+  = StNode NodeStatement+  | StProto ProtoStatement+  | StRoute Route+  deriving (Generic,Eq)++class NodeLike a where+  node :: NodeTypeId -> [NodeBodyElement] -> a++instance NodeLike Statement where+  node i b = StNode (NodeStatement (Node i b))++instance NodeLike NodeStatement where+  node i b = NodeStatement (Node i b)++instance NodeLike Node where+  node i b = Node i b++instance NodeLike FieldValue where+  node i b = Snode (Just (NodeStatement (Node i b)))++instance Show Statement where+  show (StNode (NodeStatement (Node i b))) = "node " ++ show i ++ " " ++ show b+  show (StNode s) = "StNode (" ++ show s ++ ")"+  show (StProto s) = "StProto (" ++ show s ++ ")"+  show (StRoute s) = "StRoute (" ++ show s ++ ")"++data NodeStatement+  = NodeStatement Node+  | DEF NodeNameId Node+  | USE NodeNameId+  deriving (Generic,Show,Eq)++data ProtoStatement+  = Proto NodeTypeId [Interface] [ProtoStatement] Node [Statement]+  | ExternProto NodeTypeId [ExternInterface] URLList+  deriving (Generic,Show,Eq)++data RestrictedInterface+  = RestrictedInterfaceEventIn FieldType EventInId+  | RestrictedInterfaceEventOut FieldType EventOutId+  | RestrictedInterfaceField FieldType FieldId FieldValue+  deriving (Generic,Show,Eq)++data Interface+  = InterfaceEventIn FieldType EventInId+  | InterfaceEventOut FieldType EventOutId+  | InterfaceField FieldType FieldId FieldValue+  | InterfaceExposedField FieldType FieldId FieldValue+  deriving (Generic,Show,Eq)++data ExternInterface+  = ExternInterfaceEventIn FieldType EventInId+  | ExternInterfaceEventOut FieldType EventOutId+  | ExternInterfaceField FieldType FieldId+  | ExternInterfaceExposedField FieldType FieldId+  deriving (Generic,Show,Eq)++data Route+  = Route NodeNameId EventOutId NodeNameId EventInId+  deriving (Generic,Show,Eq)++newtype URLList = URLList [String]+  deriving (Generic,Show,Eq)++data Node+  = Node NodeTypeId [NodeBodyElement]+  | Script [ScriptBodyElement]+  deriving (Generic,Show,Eq)++data ScriptBodyElement+  = SBNode NodeBodyElement+  | SBRestrictedInterface RestrictedInterface+  | SBEventIn FieldType EventInId EventInId+  | SBEventOut FieldType EventOutId EventOutId+  | SBFieldId FieldType FieldId FieldId+  deriving (Generic,Show,Eq)++data NodeBodyElement+  = FV FieldId FieldValue+  | NBFieldId FieldId FieldId+  | NBEventIn EventInId EventInId+  | NBEventOut EventOutId EventOutId+  | NBRoute Route+  | NBProto ProtoStatement+  deriving (Generic,Show,Eq)++newtype NodeNameId = NodeNameId String+  deriving (Generic,Show,Eq)++newtype NodeTypeId = NodeTypeId String+  deriving (Generic,Eq)++newtype FieldId = FieldId String+  deriving (Generic,Eq)++newtype EventInId = EventInId String+  deriving (Generic,Show,Eq)++newtype EventOutId = EventOutId String+  deriving (Generic,Show,Eq)++data FieldType+  = MFBool+  | MFColor+  | MFFloat+  | MFString+  | MFTime+  | MFVec2f+  | MFVec3f+  | MFNode+  | MFRotation+  | MFInt32+  | SFBool+  | SFColor+  | SFFloat+  | SFImage+  | SFInt32+  | SFNode+  | SFRotation+  | SFString+  | SFTime+  | SFVec2f+  | SFVec3f+  deriving (Generic,Show,Eq)++newtype Color = Color (Float,Float,Float) deriving (Generic,Show,Eq)+newtype Time = Time Double deriving (Generic,Show,Eq)++data FieldValue+  = Sbool Bool+  | Scolor Color+  | Sfloat Float+  | Simage [Int32]+  | Sint32 Int32+  | Snode (Maybe NodeStatement)+  | Srotation (Float,Float,Float,Float)+  | Sstring String+  | Stime Time+  | Svec2f (Float,Float)+  | Svec3f (Float,Float,Float)+  | Mbool [Bool]+  | Mcolor [Color]+  | Mfloat [Float]+  | Mint32 [Int32]+  | Mnode [NodeStatement]+  | Mrotation [(Float,Float,Float,Float)]+  | Mstring [String]+  | Mtime [Time]+  | Mvec2f [(Float,Float)]+  | Mvec3f [(Float,Float,Float)]+  deriving (Generic,Show,Eq)++instance IsString FieldValue where+  fromString s = Sstring s++instance IsString NodeNameId where+  fromString s = NodeNameId s++instance IsString NodeTypeId where+  fromString s = NodeTypeId s++instance IsString FieldId where+  fromString s = FieldId s++instance IsString EventInId where+  fromString s = EventInId s++instance IsString EventOutId where+  fromString s = EventOutId s++instance Show NodeTypeId where+  show (NodeTypeId s) = show s++instance Show FieldId where+  show (FieldId s) = show s+++instance Semigroup Node where+  (<>) a b = +    let (Node (NodeTypeId xname) xbody) = a+        (Node (NodeTypeId yname) ybody) = b+    in Node (NodeTypeId (xname ++ yname)) (xbody++ybody)++instance Monoid Node where+  mempty = Node "" []++class ToNode a where+  toNode :: NodeLike b => a -> b+  default toNode :: (Generic a, ToNode' (Rep a), NodeLike b) => a -> b+  toNode a =+    let (Node name body) = toNode' (from a)+    in node name body++instance ToNode Bool where+  toNode a = node "" [(FV "" (Sbool a))]++instance ToNode Color where+  toNode a = node "" [(FV "" (Scolor a))]++instance ToNode Float where+  toNode a = node "" [(FV "" (Sfloat a))]++instance ToNode Int32 where+  toNode a = node "" [(FV "" (Sint32 a))]++instance ToNode Node where+  toNode a = node "" [(FV "" (Snode (Just (NodeStatement a))))]++instance ToNode (Float,Float,Float,Float) where+  toNode a = node "" [(FV "" (Srotation a))]++instance ToNode String where+  toNode a = node "" [(FV "" (Sstring a))]++instance ToNode Time where+  toNode a = node "" [(FV "" (Stime a))]++instance ToNode (Float,Float) where+  toNode a = node "" [(FV "" (Svec2f a))]++instance ToNode (Float,Float,Float) where+  toNode a = node "" [(FV "" (Svec3f a))]++instance ToNode [Bool] where+  toNode a = node "" [(FV "" (Mbool a))]++instance ToNode [Color] where+  toNode a = node "" [(FV "" (Mcolor a))]++instance ToNode [Float] where+  toNode a = node "" [(FV "" (Mfloat a))]++instance ToNode [Int32] where+  toNode a = node "" [(FV "" (Mint32 a))]++instance ToNode [Node] where+  toNode a = node "" [(FV "" (Mnode (map NodeStatement a)))]++instance ToNode [(Float,Float,Float,Float)] where+  toNode a = node "" [(FV "" (Mrotation a))]++instance ToNode [Time] where+  toNode a = node "" [(FV "" (Mtime a))]++instance ToNode [String] where+  toNode a = node "" [(FV "" (Mstring a))]++instance ToNode [(Float,Float)] where+  toNode a = node "" [(FV "" (Mvec2f a))]++instance ToNode [(Float,Float,Float)] where+  toNode a = node "" [(FV "" (Mvec3f a))]++instance ToNode a => ToNode (Maybe a) where+  toNode (Just a) = toNode a+  toNode Nothing = node "" []++class ToNode' f where+  toNode' :: f a -> Node++instance ToNode' U1 where+  toNode' U1 = mempty++instance (ToNode' f, ToNode' g) => ToNode' (f :+: g) where+  toNode' (L1 x) = toNode' x+  toNode' (R1 x) = toNode' x++instance (ToNode' f, ToNode' g) => ToNode' (f :*: g) where+  toNode' (x :*: y) = toNode' x <> toNode' y++instance (ToNode c) => ToNode' (K1 i c) where+  toNode' (K1 x) = toNode x++instance (Selector c, ToNode' f) => ToNode' (M1 S c f) where+  toNode' a@(M1 x) =+    case toNode' x of+      (Node "" [(FV _ v)]) -> Node "" [(FV (FieldId (selName a)) v)]+      v@(Node x _) -> Node "" [(FV (FieldId (selName a)) (Snode (Just (NodeStatement v))))]++instance (Constructor c, ToNode' f) => ToNode' (M1 C c f) where+  toNode' a@(M1 x) = Node (NodeTypeId (conName a)) [] <> toNode' x++instance (ToNode' f) => ToNode' (M1 D c f) where+  toNode' (M1 x) = toNode' x
+ test/doctests.hs view
@@ -0,0 +1,11 @@+module Main where++import Test.DocTest++main :: IO ()+main = do+  doctest $+    [+      "-XOverloadedStrings",+      "src/Data/VRML/Parser.hs"+    ]