Export duplicate JavaScript functions with parametric polymorphism

generator/IDL/AST.hs

@@ -1,11 +1,25 @@
 module IDL.AST where
 
-data IDL = IDL
-    { enums      :: [Decl]
-    , comments   :: [Decl]
-    , functions  :: [Decl]
-    , attributes :: [Decl]
-    , types      :: [Type]
+import qualified Data.Map as Map
+
+data Type
+  = Generic
+  | Concrete
+    { typeName     :: String
+    , typeIsArray  :: Bool
+    , typeIsMaybe' :: Bool
+    }
+  deriving Show
+
+instance Eq Type where
+  x == y = typeName x == typeName y
+
+instance Ord Type where
+  compare x y = compare (typeName x) (typeName y)
+
+data Arg = Arg
+    { argType :: Type
+    , argName :: String
     }
   deriving Show
 
@@ -19,6 +33,7 @@ data Decl
       }
   | Function
       { methodName    :: String
+      , actualName    :: String
       , methodRetType :: Type
       , methodArgs    :: [Arg]
       , methodRaises  :: Maybe String
@@ -31,36 +46,15 @@ data Decl
   | Typedef
   deriving Show
 
-instance Eq Decl where
-  x@Enum{} == y@Enum{} = enumName x == enumName y
-  x@Comment{} == y@Comment{} = comment x == comment y
-  x@Function{} == y@Function{} = methodName x == methodName y
-  x@Attribute{} == y@Attribute{} = attrName x == attrName y
-  _ == _ = False
-
-data Type
-  = Generic
-  | Concrete
-    { typeName     :: String
-    , typeIsArray  :: Bool
-    , typeIsMaybe' :: Bool
-    }
-  deriving Show
-
-instance Eq Type where
-  x == y = typeName x == typeName y
-
-instance Ord Type where
-  compare x y = compare (typeName x) (typeName y)
-
-data Arg = Arg
-    { argType :: Type
-    , argName :: String
+data IDL = IDL
+    { enums      :: Map.Map String Decl
+    , functions  :: Map.Map String Decl
+    , types      :: Map.Map String Type
     }
   deriving Show
 
 emptyIdl :: IDL
-emptyIdl = IDL [] [] [] [] []
+emptyIdl = IDL Map.empty Map.empty Map.empty
 
 webglContext :: Arg
 webglContext = Arg (Concrete "WebGLContext" False False) "webgl"

generator/IDL/Cleaner.hs

@@ -0,0 +1,90 @@
+module IDL.Cleaner
+( declsToIdl
+, getEnums
+, getFuncs
+, getTypes
+) where
+
+import Data.List (foldl')
+
+import qualified Data.Map as Map
+
+import IDL.AST
+
+-- constants
+
+excludedTypes :: [String]
+excludedTypes =
+    [ "ArrayBuffer"
+    , "DOMString"
+    , "Float32Array"
+    , "FloatArray"
+    , "GLbitfield"
+    , "GLboolean"
+    , "GLbyte"
+    , "GLclampf"
+    , "GLenum"
+    , "GLfloat"
+    , "GLint"
+    , "GLintptr"
+    , "GLshort"
+    , "GLsizei"
+    , "GLsizeiptr"
+    , "GLubyte"
+    , "GLuint"
+    , "GLushort"
+    , "HTMLCanvasElement"
+    , "Int32Array"
+    , "WebGLContextAttributes"
+    , "any"
+    , "boolean"
+    , "long"
+    , "object"
+    , "sequence"
+    , "void"
+    ]
+
+-- public functions
+
+declsToIdl :: [Decl] -> IDL
+declsToIdl = cleanup . foldr partition emptyIdl
+
+getTypes :: IDL -> [Type]
+getTypes =  map snd . Map.toList . types
+
+getEnums :: IDL -> [Decl]
+getEnums = map snd . Map.toList . enums
+
+getFuncs :: IDL -> [Decl]
+getFuncs = map snd . Map.toList . functions
+
+-- private functions
+
+partition :: Decl -> IDL -> IDL
+partition e@Enum{} idl = idl
+    { enums = Map.insert (enumName e) e (enums idl)
+    }
+partition f@Function{} idl = idl
+    { functions = underscore f $ functions idl
+    , types = insertFuncTypes f $ types idl
+    }
+partition _ idl = idl
+
+underscore :: Decl -> Map.Map String Decl -> Map.Map String Decl
+underscore f fs
+    | Map.member name fs = underscore (f { methodName = name ++ "_" }) fs
+    | otherwise          = Map.insert name f fs
+  where
+    name = methodName f
+
+insertFuncTypes :: Decl -> Map.Map String Type -> Map.Map String Type
+insertFuncTypes f types = foldl' insert types ftypes
+  where
+    ftypes = methodRetType f : map argType (funcArgs f)
+    insert ts Generic = ts
+    insert ts t = Map.insert (typeName t) t ts
+
+cleanup :: IDL -> IDL
+cleanup idl = idl { types = removeExcluded $ types idl }
+  where
+    removeExcluded types = foldl' (flip Map.delete) types excludedTypes

generator/IDL/Parser.hs

@@ -1,103 +1,48 @@
-module IDL.Parser (parseIdl) where
+module IDL.Parser (parseDecls) where
 
 import Control.Monad (liftM)
 import Data.Functor.Identity (Identity(..))
-import Data.List (nub)
 
-import qualified Text.Parsec.Token                      as PP
-import qualified Text.Parsec                            as PP
-import qualified Text.Parsec.Error                      as PP
-import qualified Text.ParserCombinators.Parsec.Language as PP
-import qualified Text.ParserCombinators.Parsec          as PP (Parser)
+import qualified Text.Parsec.Token                      as Par
+import qualified Text.Parsec                            as Par
+import qualified Text.Parsec.Error                      as Par
+import qualified Text.ParserCombinators.Parsec.Language as Par
+import qualified Text.ParserCombinators.Parsec          as Par (Parser)
 
 import IDL.AST
 
-type Parse a = PP.Parsec String () a
-
-symbol'     = PP.symbol     lexer
-whiteSpace' = PP.whiteSpace lexer
-identifier' = PP.identifier lexer
-integer'    = PP.integer    lexer
-semi'       = PP.semi       lexer
-parens'     = PP.parens     lexer
-brackets'   = PP.brackets   lexer
-angles'     = PP.angles     lexer
-
-excludedTypes :: [String]
-excludedTypes =
-    [ "ArrayBuffer"
-    , "DOMString"
-    , "Float32Array"
-    , "FloatArray"
-    , "GLbitfield"
-    , "GLboolean"
-    , "GLbyte"
-    , "GLclampf"
-    , "GLenum"
-    , "GLfloat"
-    , "GLint"
-    , "GLintptr"
-    , "GLshort"
-    , "GLsizei"
-    , "GLsizeiptr"
-    , "GLubyte"
-    , "GLuint"
-    , "GLushort"
-    , "HTMLCanvasElement"
-    , "Int32Array"
-    , "WebGLContextAttributes"
-    , "any"
-    , "boolean"
-    , "object"
-    , "sequence"
-    , "void"
-    ]
-
-lexer :: PP.GenTokenParser String u Identity
-lexer = PP.makeTokenParser PP.emptyDef
-
-parseIdl :: Parse IDL
-parseIdl = parseDecls >>= return . cleanup . foldr partition emptyIdl . nub
-
--- helpers
-
-partition :: Decl -> IDL -> IDL
-partition e@Enum{} idl = idl
-    { enums = e : enums idl
-    }
-partition c@Comment{} idl = idl
-    { comments = c : comments idl
-    }
-partition f@Function{} idl = idl
-    { functions = f : functions idl
-    , types = methodRetType f : map argType (funcArgs f) ++ types idl
-    }
-partition a@Attribute{} idl = idl
-    { attributes = a : attributes idl
-    , types = attrType a : types idl
-    }
-partition _ idl = idl
-
-cleanup :: IDL -> IDL
-cleanup idl = idl { types = nub . filter onlyAllowedTypes $ types idl }
-  where
-    onlyAllowedTypes Concrete{ typeName = t } = t `notElem` excludedTypes
-    onlyAllowedTypes _                        = False
+type Parse a = Par.Parsec String () a
+
+-- constants
+
+symbol'     = Par.symbol     lexer
+whiteSpace' = Par.whiteSpace lexer
+identifier' = Par.identifier lexer
+integer'    = Par.integer    lexer
+semi'       = Par.semi       lexer
+parens'     = Par.parens     lexer
+brackets'   = Par.brackets   lexer
+angles'     = Par.angles     lexer
 
--- parsers
+lexer :: Par.GenTokenParser String u Identity
+lexer = Par.makeTokenParser Par.emptyDef
+
+-- public functions
 
 parseDecls :: Parse [Decl]
 parseDecls =
-    PP.manyTill (whiteSpace' >> parseDecl) PP.eof PP.<?> "expecting idl"
+    Par.manyTill (whiteSpace' >> parseDecl) Par.eof Par.<?> "expecting idl"
+
+-- private functions
 
 parseDecl :: Parse Decl
-parseDecl = decl PP.<?> "expecting decl"
+parseDecl = decl Par.<?> "expecting decl"
   where
-    decl = PP.try parseConst   PP.<|>
-           PP.try parseComment PP.<|>
-           PP.try parseMethod  PP.<|>
-           PP.try parseAttr    PP.<|>
-           PP.try parseTypedef
+    decl = Par.try parseConst   Par.<|>
+           Par.try parseComment Par.<|>
+           Par.try parseMethod  Par.<|>
+           Par.try parseAttr    Par.<|>
+           Par.try parseTypedef
 
 parseConst :: Parse Decl
 parseConst = do
@@ -113,36 +58,37 @@ parseConst = do
       }
 
 parseComment :: Parse Decl
-parseComment = inlineComment PP.<|> blockComment
+parseComment = inlineComment Par.<|> blockComment
   where
-    inlineComment = PP.try $ do
+    inlineComment = Par.try $ do
         symbol' "//"
-        comment <- PP.manyTill PP.anyChar PP.newline
-        PP.optional whiteSpace'
+        comment <- Par.manyTill Par.anyChar Par.newline
+        Par.optional whiteSpace'
         return Comment { comment = comment }
     blockComment = do
         symbol' "/*"
-        comment <- PP.manyTill PP.anyChar $ symbol' "*/"
+        comment <- Par.manyTill Par.anyChar $ symbol' "*/"
         return Comment { comment = comment }
 
 parseMethod :: Parse Decl
 parseMethod = do
-    PP.optional $ symbol' "[WebGLHandlesContextLoss]"
+    Par.optional $ symbol' "[WebGLHandlesContextLoss]"
     returnType <- parseType
     methodName <- identifier'
-    args <- parens' . PP.sepBy parseArg $ symbol' ","
-    condRaises <- PP.option Nothing parseRaises
+    args <- parens' . Par.sepBy parseArg $ symbol' ","
+    condRaises <- Par.option Nothing parseRaises
     semi'
     return Function
       { methodName    = methodName
+      , actualName    = methodName
       , methodRetType = returnType
       , methodArgs    = args
       , methodRaises  = condRaises
       }
 
 parseAttr :: Parse Decl
 parseAttr = do
-    isReadonly <- PP.option False $ symbol' "readonly" >> return True
+    isReadonly <- Par.option False $ symbol' "readonly" >> return True
     symbol' "attribute"
     typ <- parseType
     name <- identifier'
@@ -156,12 +102,12 @@ parseAttr = do
 parseTypedef :: Parse Decl
 parseTypedef = do
     symbol' "typedef"
-    PP.manyTill PP.anyChar semi'
+    Par.manyTill Par.anyChar semi'
     return Typedef
 
 
 parseType :: Parse Type
-parseType = typ PP.<?> "expecting type"
+parseType = typ Par.<?> "expecting type"
   where
     arrayName = do
         symbol' "sequence"
@@ -171,8 +117,8 @@ parseType = typ PP.<?> "expecting type"
         name <- identifier'
         return (name, False)
     typ = do
-        (name, isArray) <- PP.try arrayName PP.<|> singleName
-        isMaybe <- PP.option False $ symbol' "?" >> return True
+        (name, isArray) <- Par.try arrayName Par.<|> singleName
+        isMaybe <- Par.option False $ symbol' "?" >> return True
         return $
           if name `elem` ["any", "object"]
           then Generic