99f82ce · rowtype-yoga/purescript-native

docgen/Main.hs+5−5

compare with golang

unifiedsplit

@@ -106,7 +106,7 @@ isExported (Just exps) decl = any (matches decl) exps

106 where

107 matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'

108 matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'

109− matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'

109+ matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'

110 matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'

111 matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'

112 matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'

@@ -138,10 +138,10 @@ renderDeclaration n _ (P.TypeDeclaration ident ty) =

138 atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty

139renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =

140 atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty

141−renderDeclaration n exps (P.DataDeclaration name args ctors) = do

141+renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do

142 let typeName = P.runProperName name ++ (if null args then "" else " " ++ unwords args)

143 let exported = filter (isDctorExported name exps . fst) ctors

144− atIndent n $ "data " ++ typeName ++ (if null exported then "" else " where")

144+ atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")

145 forM_ exported $ \(ctor, tys) ->

146 atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> prettyPrintType' ty ++ " -> ") tys ++ typeName

147renderDeclaration n _ (P.ExternDataDeclaration name kind) =

@@ -168,14 +168,14 @@ prettyPrintType' :: P.Type -> String

168prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

169 where

170 dePrim ty@(P.TypeConstructor (P.Qualified _ name))

171− | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =

171+ | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =

172 P.TypeConstructor $ P.Qualified Nothing name

173 dePrim other = other

174

175getName :: P.Declaration -> String

176getName (P.TypeDeclaration ident _) = show ident

177getName (P.ExternDeclaration _ ident _ _) = show ident

178−getName (P.DataDeclaration name _ _) = P.runProperName name

178+getName (P.DataDeclaration _ name _ _) = P.runProperName name

179getName (P.ExternDataDeclaration name _) = P.runProperName name

180getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name

181getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name

src/Language/PureScript/CodeGen/JS.hs+1−1

@@ -106,7 +106,7 @@ declToJs opts mp (BindingGroupDeclaration vals) e = do

106 js <- valueToJs opts mp e val

107 return $ JSVariableIntroduction (identToJs ident) (Just js)

108 return $ Just jss

109−declToJs _ mp (DataDeclaration _ _ ctors) e = do

109+declToJs _ mp (DataDeclaration _ _ _ ctors) e = do

110 return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

111 let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"

112 in [ makeConstructor ctor (length tys)

src/Language/PureScript/DeadCodeElimination.hs+3−3

@@ -52,7 +52,7 @@ eliminateDeadCode entryPoints ms = map go ms

52 valueExists _ _ = False

53

54 typeExists :: ProperName -> Declaration -> Bool

55− typeExists name (DataDeclaration name' _ _) = name == name'

55+ typeExists name (DataDeclaration _ name' _ _) = name == name'

56 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls

57 typeExists name (PositionedDeclaration _ d) = typeExists name d

58 typeExists _ _ = False

@@ -64,7 +64,7 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds

64 where

65 go :: Declaration -> [(Key, [Key])]

66 go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

67− go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

67+ go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

68 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

69 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

70 go (DataBindingGroupDeclaration ds') = concatMap go ds'

@@ -91,7 +91,7 @@ isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _

91isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =

92 let Just v' = vertexFor (moduleName, Left $ Op name)

93 in any (\v -> path graph v v') entryPointVertices

94−isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =

94+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =

95 any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)

96 in any (\v -> path graph v v') entryPointVertices) dctors

97isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =

src/Language/PureScript/Declarations.hs+19−2

@@ -113,6 +113,23 @@ instance Eq DeclarationRef where

113 r == (PositionedDeclarationRef _ r') = r == r'

114 _ == _ = False

115

116+-- |

117+-- The type of a data type declaration

118+--

119+data DataType

120+ -- |

121+ -- A standard data constructor

122+ --

123+ = Data

124+ -- |

125+ -- A newtype constructor

126+ --

127+ | Newtype deriving (Eq, Ord, D.Data, D.Typeable)

128+

129+instance Show DataType where

130+ show Data = "data"

131+ show Newtype = "newtype"

132+

116-- |

133-- |

117-- The data type of declarations

134-- The data type of declarations

118--

135--

@@ -120,7 +137,7 @@ data Declaration

120 -- |

137 -- |

121 -- A data type declaration (name, arguments, data constructors)

138 -- A data type declaration (name, arguments, data constructors)

122 --

139 --

123− = DataDeclaration ProperName [String] [(ProperName, [Type])]

140+ = DataDeclaration DataType ProperName [String] [(ProperName, [Type])]

124 -- |

141 -- |

125 -- A minimal mutually recursive set of data type declarations

142 -- A minimal mutually recursive set of data type declarations

126 --

143 --

@@ -814,7 +831,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

814accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

831accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

815accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

832accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

816 where

833 where

817− forDecls (DataDeclaration _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

834+ forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

818 forDecls (ExternDeclaration _ _ _ ty) = f ty

835 forDecls (ExternDeclaration _ _ _ ty) = f ty

819 forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)

836 forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)

820 forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)

837 forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)

src/Language/PureScript/Parser/Declarations.hs+1−1

@@ -54,7 +54,7 @@ parseDataDeclaration = do

54 ctors <- P.option [] $ do

55 _ <- lexeme $ indented *> P.char '='

56 sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe

57− return $ DataDeclaration name tyArgs ctors

57+ return $ DataDeclaration Data name tyArgs ctors

58

59parseTypeDeclaration :: P.Parsec String ParseState Declaration

60parseTypeDeclaration =

src/Language/PureScript/Sugar/BindingGroups.hs+1−1

@@ -118,7 +118,7 @@ getIdent (PositionedDeclaration _ d) = getIdent d

118getIdent _ = error "Expected ValueDeclaration"

119

120getProperName :: Declaration -> ProperName

121−getProperName (DataDeclaration pn _ _) = pn

121+getProperName (DataDeclaration _ pn _ _) = pn

122getProperName (TypeSynonymDeclaration pn _ _) = pn

123getProperName (PositionedDeclaration _ d) = getProperName d

124getProperName _ = error "Expected DataDeclaration"

src/Language/PureScript/Sugar/Names.hs+3−3

@@ -182,8 +182,8 @@ renameInModule imports exports (Module mn decls exps) =

182

183 updateDecl :: (Maybe SourcePos, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourcePos, [Ident]), Declaration)

184 updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)

185− updateDecl (pos, bound) (DataDeclaration name args dctors) =

185+ updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

186− (,) (pos, bound) <$> (DataDeclaration name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)

186+ (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)

187 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =

188 (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)

189 updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =

@@ -297,7 +297,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

297 go env'' (TypeDeclaration name _) = addValue env'' mn name

298 go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d

299 go _ _ = error "Invalid declaration in TypeClassDeclaration"

300− addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)

300+ addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)

301 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

302 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

303 addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name

src/Language/PureScript/TypeChecker.hs+2−2

@@ -111,7 +111,7 @@ checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance hea

111--

112typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]

113typeCheckAll _ _ [] = return []

114−typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do

114+typeCheckAll mainModuleName moduleName (d@(DataDeclaration _ name args dctors) : rest) = do

115 rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do

116 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

117 addDataType moduleName name args dctors ctorKind

@@ -132,7 +132,7 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

132 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)

133 toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'

134 toTypeSynonym _ = Nothing

135− toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)

135+ toDataDecl (DataDeclaration _ nm args dctors) = Just (nm, args, dctors)

136 toDataDecl (PositionedDeclaration _ d') = toDataDecl d'

137 toDataDecl _ = Nothing

138typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do