99f82ce · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Add param to dctors for newtype representation

commit99f82cec514e4afb036aa30a52fb52ead9d9fd64 authorGary Burgess <gary.burgess@gmail.com> dateSat 26 Jul 2014, 11:55 (12 years ago) parent385c92f

8 files changed+35−18

compare with golang

unifiedsplit

docgen/Main.hs+5−5 src/Language/PureScript/CodeGen/JS.hs+1−1 src/Language/PureScript/DeadCodeElimination.hs+3−3 src/Language/PureScript/Declarations.hs+19−2 src/Language/PureScript/Parser/Declarations.hs+1−1 src/Language/PureScript/Sugar/BindingGroups.hs+1−1 src/Language/PureScript/Sugar/Names.hs+3−3 src/Language/PureScript/TypeChecker.hs+2−2

docgen/Main.hs+5−5

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

106106 where

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

108108 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'

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

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

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

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

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

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

140140 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

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

143143 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")

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

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

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

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

168168prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

169169 where

170170 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 =

172172 P.TypeConstructor $ P.Qualified Nothing name

173173 dePrim other = other

174174

175175getName :: P.Declaration -> String

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

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

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

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

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

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

181181getName (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

106106 js <- valueToJs opts mp e val

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

108108 return $ Just jss

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

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

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

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

112112 in [ makeConstructor ctor (length tys)

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

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

5252 valueExists _ _ = False

5353

5454 typeExists :: ProperName -> Declaration -> Bool

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

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

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

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

5858 typeExists _ _ = False

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

6464 where

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

6666 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

113113 r == (PositionedDeclarationRef _ r') = r == r'

114114 _ == _ = False

115115

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+

116133-- |

117134-- The data type of declarations

118135--

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

120137 -- |

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

122139 --

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

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

124141 -- |

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

126143 --

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

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

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

816833 where

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

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

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

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

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

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

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

5454 ctors <- P.option [] $ do

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

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

57− return $ DataDeclaration name tyArgs ctors

57+ return $ DataDeclaration Data name tyArgs ctors

5858

5959parseTypeDeclaration :: P.Parsec String ParseState Declaration

6060parseTypeDeclaration =

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

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

118118getIdent _ = error "Expected ValueDeclaration"

119119

120120getProperName :: Declaration -> ProperName

121−getProperName (DataDeclaration pn _ _) = pn

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

122122getProperName (TypeSynonymDeclaration pn _ _) = pn

123123getProperName (PositionedDeclaration _ d) = getProperName d

124124getProperName _ = error "Expected DataDeclaration"

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

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

182182

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

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

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

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

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

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

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

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

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

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

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

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

299299 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)

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

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

303303 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

111111--

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

113113typeCheckAll _ _ [] = return []

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

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

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

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

117117 addDataType moduleName name args dctors ctorKind

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

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

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

134134 toTypeSynonym _ = Nothing

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

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

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

137137 toDataDecl _ = Nothing

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