Skip to content

Commit a4dd0c4

Browse files
JonplussedJonplussed
committed
Export duplicate JavaScript functions with parametric polymorphism
1 parent 3c0f092 commit a4dd0c4

10 files changed

Lines changed: 1881 additions & 1497 deletions

File tree

‎docs/README.md‎

Lines changed: 777 additions & 644 deletions
Large diffs are not rendered by default.

‎generator/IDL/AST.hs‎

Lines changed: 26 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,25 @@
11
module IDL.AST where
22

3-
data IDL = IDL
4-
{ enums :: [Decl]
5-
, comments :: [Decl]
6-
, functions :: [Decl]
7-
, attributes :: [Decl]
8-
, types :: [Type]
3+
import qualified Data.Map as Map
4+
5+
data Type
6+
= Generic
7+
| Concrete
8+
{ typeName :: String
9+
, typeIsArray :: Bool
10+
, typeIsMaybe' :: Bool
11+
}
12+
deriving Show
13+
14+
instance Eq Type where
15+
x == y = typeName x == typeName y
16+
17+
instance Ord Type where
18+
compare x y = compare (typeName x) (typeName y)
19+
20+
data Arg = Arg
21+
{ argType :: Type
22+
, argName :: String
923
}
1024
deriving Show
1125

@@ -19,6 +33,7 @@ data Decl
1933
}
2034
| Function
2135
{ methodName :: String
36+
, actualName :: String
2237
, methodRetType :: Type
2338
, methodArgs :: [Arg]
2439
, methodRaises :: Maybe String
@@ -31,36 +46,15 @@ data Decl
3146
| Typedef
3247
deriving Show
3348

34-
instance Eq Decl where
35-
x@Enum{} == y@Enum{} = enumName x == enumName y
36-
x@Comment{} == y@Comment{} = comment x == comment y
37-
x@Function{} == y@Function{} = methodName x == methodName y
38-
x@Attribute{} == y@Attribute{} = attrName x == attrName y
39-
_ == _ = False
40-
41-
data Type
42-
= Generic
43-
| Concrete
44-
{ typeName :: String
45-
, typeIsArray :: Bool
46-
, typeIsMaybe' :: Bool
47-
}
48-
deriving Show
49-
50-
instance Eq Type where
51-
x == y = typeName x == typeName y
52-
53-
instance Ord Type where
54-
compare x y = compare (typeName x) (typeName y)
55-
56-
data Arg = Arg
57-
{ argType :: Type
58-
, argName :: String
49+
data IDL = IDL
50+
{ enums :: Map.Map String Decl
51+
, functions :: Map.Map String Decl
52+
, types :: Map.Map String Type
5953
}
6054
deriving Show
6155

6256
emptyIdl :: IDL
63-
emptyIdl = IDL [] [] [] [] []
57+
emptyIdl = IDL Map.empty Map.empty Map.empty
6458

6559
webglContext :: Arg
6660
webglContext = Arg (Concrete "WebGLContext" False False) "webgl"

‎generator/IDL/Cleaner.hs‎

Lines changed: 90 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,90 @@
1+
module IDL.Cleaner
2+
( declsToIdl
3+
, getEnums
4+
, getFuncs
5+
, getTypes
6+
) where
7+
8+
import Data.List (foldl')
9+
10+
import qualified Data.Map as Map
11+
12+
import IDL.AST
13+
14+
-- constants
15+
16+
excludedTypes :: [String]
17+
excludedTypes =
18+
[ "ArrayBuffer"
19+
, "DOMString"
20+
, "Float32Array"
21+
, "FloatArray"
22+
, "GLbitfield"
23+
, "GLboolean"
24+
, "GLbyte"
25+
, "GLclampf"
26+
, "GLenum"
27+
, "GLfloat"
28+
, "GLint"
29+
, "GLintptr"
30+
, "GLshort"
31+
, "GLsizei"
32+
, "GLsizeiptr"
33+
, "GLubyte"
34+
, "GLuint"
35+
, "GLushort"
36+
, "HTMLCanvasElement"
37+
, "Int32Array"
38+
, "WebGLContextAttributes"
39+
, "any"
40+
, "boolean"
41+
, "long"
42+
, "object"
43+
, "sequence"
44+
, "void"
45+
]
46+
47+
-- public functions
48+
49+
declsToIdl :: [Decl] -> IDL
50+
declsToIdl = cleanup . foldr partition emptyIdl
51+
52+
getTypes :: IDL -> [Type]
53+
getTypes = map snd . Map.toList . types
54+
55+
getEnums :: IDL -> [Decl]
56+
getEnums = map snd . Map.toList . enums
57+
58+
getFuncs :: IDL -> [Decl]
59+
getFuncs = map snd . Map.toList . functions
60+
61+
-- private functions
62+
63+
partition :: Decl -> IDL -> IDL
64+
partition e@Enum{} idl = idl
65+
{ enums = Map.insert (enumName e) e (enums idl)
66+
}
67+
partition f@Function{} idl = idl
68+
{ functions = underscore f $ functions idl
69+
, types = insertFuncTypes f $ types idl
70+
}
71+
partition _ idl = idl
72+
73+
underscore :: Decl -> Map.Map String Decl -> Map.Map String Decl
74+
underscore f fs
75+
| Map.member name fs = underscore (f { methodName = name ++ "_" }) fs
76+
| otherwise = Map.insert name f fs
77+
where
78+
name = methodName f
79+
80+
insertFuncTypes :: Decl -> Map.Map String Type -> Map.Map String Type
81+
insertFuncTypes f types = foldl' insert types ftypes
82+
where
83+
ftypes = methodRetType f : map argType (funcArgs f)
84+
insert ts Generic = ts
85+
insert ts t = Map.insert (typeName t) t ts
86+
87+
cleanup :: IDL -> IDL
88+
cleanup idl = idl { types = removeExcluded $ types idl }
89+
where
90+
removeExcluded types = foldl' (flip Map.delete) types excludedTypes

‎generator/IDL/Parser.hs‎

Lines changed: 45 additions & 99 deletions
Original file line numberDiff line numberDiff line change
@@ -1,103 +1,48 @@
1-
module IDL.Parser (parseIdl) where
1+
module IDL.Parser (parseDecls) where
22

33
import Control.Monad (liftM)
44
import Data.Functor.Identity (Identity(..))
5-
import Data.List (nub)
65

7-
import qualified Text.Parsec.Token as PP
8-
import qualified Text.Parsec as PP
9-
import qualified Text.Parsec.Error as PP
10-
import qualified Text.ParserCombinators.Parsec.Language as PP
11-
import qualified Text.ParserCombinators.Parsec as PP (Parser)
6+
import qualified Text.Parsec.Token as Par
7+
import qualified Text.Parsec as Par
8+
import qualified Text.Parsec.Error as Par
9+
import qualified Text.ParserCombinators.Parsec.Language as Par
10+
import qualified Text.ParserCombinators.Parsec as Par (Parser)
1211

1312
import IDL.AST
1413

15-
type Parse a = PP.Parsec String () a
16-
17-
symbol' = PP.symbol lexer
18-
whiteSpace' = PP.whiteSpace lexer
19-
identifier' = PP.identifier lexer
20-
integer' = PP.integer lexer
21-
semi' = PP.semi lexer
22-
parens' = PP.parens lexer
23-
brackets' = PP.brackets lexer
24-
angles' = PP.angles lexer
25-
26-
excludedTypes :: [String]
27-
excludedTypes =
28-
[ "ArrayBuffer"
29-
, "DOMString"
30-
, "Float32Array"
31-
, "FloatArray"
32-
, "GLbitfield"
33-
, "GLboolean"
34-
, "GLbyte"
35-
, "GLclampf"
36-
, "GLenum"
37-
, "GLfloat"
38-
, "GLint"
39-
, "GLintptr"
40-
, "GLshort"
41-
, "GLsizei"
42-
, "GLsizeiptr"
43-
, "GLubyte"
44-
, "GLuint"
45-
, "GLushort"
46-
, "HTMLCanvasElement"
47-
, "Int32Array"
48-
, "WebGLContextAttributes"
49-
, "any"
50-
, "boolean"
51-
, "object"
52-
, "sequence"
53-
, "void"
54-
]
55-
56-
lexer :: PP.GenTokenParser String u Identity
57-
lexer = PP.makeTokenParser PP.emptyDef
58-
59-
parseIdl :: Parse IDL
60-
parseIdl = parseDecls >>= return . cleanup . foldr partition emptyIdl . nub
61-
62-
-- helpers
63-
64-
partition :: Decl -> IDL -> IDL
65-
partition e@Enum{} idl = idl
66-
{ enums = e : enums idl
67-
}
68-
partition c@Comment{} idl = idl
69-
{ comments = c : comments idl
70-
}
71-
partition f@Function{} idl = idl
72-
{ functions = f : functions idl
73-
, types = methodRetType f : map argType (funcArgs f) ++ types idl
74-
}
75-
partition a@Attribute{} idl = idl
76-
{ attributes = a : attributes idl
77-
, types = attrType a : types idl
78-
}
79-
partition _ idl = idl
80-
81-
cleanup :: IDL -> IDL
82-
cleanup idl = idl { types = nub . filter onlyAllowedTypes $ types idl }
83-
where
84-
onlyAllowedTypes Concrete{ typeName = t } = t `notElem` excludedTypes
85-
onlyAllowedTypes _ = False
14+
type Parse a = Par.Parsec String () a
15+
16+
-- constants
17+
18+
symbol' = Par.symbol lexer
19+
whiteSpace' = Par.whiteSpace lexer
20+
identifier' = Par.identifier lexer
21+
integer' = Par.integer lexer
22+
semi' = Par.semi lexer
23+
parens' = Par.parens lexer
24+
brackets' = Par.brackets lexer
25+
angles' = Par.angles lexer
8626

87-
-- parsers
27+
lexer :: Par.GenTokenParser String u Identity
28+
lexer = Par.makeTokenParser Par.emptyDef
29+
30+
-- public functions
8831

8932
parseDecls :: Parse [Decl]
9033
parseDecls =
91-
PP.manyTill (whiteSpace' >> parseDecl) PP.eof PP.<?> "expecting idl"
34+
Par.manyTill (whiteSpace' >> parseDecl) Par.eof Par.<?> "expecting idl"
35+
36+
-- private functions
9237

9338
parseDecl :: Parse Decl
94-
parseDecl = decl PP.<?> "expecting decl"
39+
parseDecl = decl Par.<?> "expecting decl"
9540
where
96-
decl = PP.try parseConst PP.<|>
97-
PP.try parseComment PP.<|>
98-
PP.try parseMethod PP.<|>
99-
PP.try parseAttr PP.<|>
100-
PP.try parseTypedef
41+
decl = Par.try parseConst Par.<|>
42+
Par.try parseComment Par.<|>
43+
Par.try parseMethod Par.<|>
44+
Par.try parseAttr Par.<|>
45+
Par.try parseTypedef
10146

10247
parseConst :: Parse Decl
10348
parseConst = do
@@ -113,36 +58,37 @@ parseConst = do
11358
}
11459

11560
parseComment :: Parse Decl
116-
parseComment = inlineComment PP.<|> blockComment
61+
parseComment = inlineComment Par.<|> blockComment
11762
where
118-
inlineComment = PP.try $ do
63+
inlineComment = Par.try $ do
11964
symbol' "//"
120-
comment <- PP.manyTill PP.anyChar PP.newline
121-
PP.optional whiteSpace'
65+
comment <- Par.manyTill Par.anyChar Par.newline
66+
Par.optional whiteSpace'
12267
return Comment { comment = comment }
12368
blockComment = do
12469
symbol' "/*"
125-
comment <- PP.manyTill PP.anyChar $ symbol' "*/"
70+
comment <- Par.manyTill Par.anyChar $ symbol' "*/"
12671
return Comment { comment = comment }
12772

12873
parseMethod :: Parse Decl
12974
parseMethod = do
130-
PP.optional $ symbol' "[WebGLHandlesContextLoss]"
75+
Par.optional $ symbol' "[WebGLHandlesContextLoss]"
13176
returnType <- parseType
13277
methodName <- identifier'
133-
args <- parens' . PP.sepBy parseArg $ symbol' ","
134-
condRaises <- PP.option Nothing parseRaises
78+
args <- parens' . Par.sepBy parseArg $ symbol' ","
79+
condRaises <- Par.option Nothing parseRaises
13580
semi'
13681
return Function
13782
{ methodName = methodName
83+
, actualName = methodName
13884
, methodRetType = returnType
13985
, methodArgs = args
14086
, methodRaises = condRaises
14187
}
14288

14389
parseAttr :: Parse Decl
14490
parseAttr = do
145-
isReadonly <- PP.option False $ symbol' "readonly" >> return True
91+
isReadonly <- Par.option False $ symbol' "readonly" >> return True
14692
symbol' "attribute"
14793
typ <- parseType
14894
name <- identifier'
@@ -156,12 +102,12 @@ parseAttr = do
156102
parseTypedef :: Parse Decl
157103
parseTypedef = do
158104
symbol' "typedef"
159-
PP.manyTill PP.anyChar semi'
105+
Par.manyTill Par.anyChar semi'
160106
return Typedef
161107

162108

163109
parseType :: Parse Type
164-
parseType = typ PP.<?> "expecting type"
110+
parseType = typ Par.<?> "expecting type"
165111
where
166112
arrayName = do
167113
symbol' "sequence"
@@ -171,8 +117,8 @@ parseType = typ PP.<?> "expecting type"
171117
name <- identifier'
172118
return (name, False)
173119
typ = do
174-
(name, isArray) <- PP.try arrayName PP.<|> singleName
175-
isMaybe <- PP.option False $ symbol' "?" >> return True
120+
(name, isArray) <- Par.try arrayName Par.<|> singleName
121+
isMaybe <- Par.option False $ symbol' "?" >> return True
176122
return $
177123
if name `elem` ["any", "object"]
178124
then Generic

0 commit comments

Comments
 (0)