7913cf9 · rowtype-yoga/purescript-native

docgen/Main.hs+4−4

compare with golang

unifiedsplit

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

107 where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -176,7 +176,7 @@ prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

176getName :: P.Declaration -> String

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

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

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

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

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

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

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

examples/failing/NewtypeMultiArgs.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

2+

3+newtype Thing = Thing String Boolean

examples/failing/NewtypeMultiCtor.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

2+

3+newtype Thing = Thing String | Other

examples/passing/Newtype.pursnew file+22

@@ -0,0 +1,22 @@

1+module Main where

2+

3+import Control.Monad.Eff

4+import Debug.Trace

5+

6+newtype Thing = Thing String

7+

8+instance showThing :: Show Thing where

9+ show (Thing x) = "Thing " ++ show x

10+

11+newtype Box a = Box a

12+

13+instance showBox :: (Show a) => Show (Box a) where

14+ show (Box x) = "Box " ++ show x

15+

16+apply f x = f x

17+

18+main = do

19+ print $ Thing "hello"

20+ print $ Box 42

21+ print $ apply Box 9000

22+ trace "Done"

src/Language/PureScript/CodeGen/Common.hs+53

@@ -17,7 +17,14 @@ module Language.PureScript.CodeGen.Common where

17

18import Data.Char

19import Data.List (intercalate)

20+import Data.Maybe (fromMaybe)

21+import Data.Function (on)

22+

23+import qualified Data.Map as M

24+

20import Language.PureScript.Names

25import Language.PureScript.Names

26+import Language.PureScript.Environment

27+import Language.PureScript.Types

21

28

22-- |

29-- |

23-- Convert an Ident into a valid Javascript identifier:

30-- Convert an Ident into a valid Javascript identifier:

@@ -138,3 +145,49 @@ nameIsJsReserved name =

138

145

139moduleNameToJs :: ModuleName -> String

146moduleNameToJs :: ModuleName -> String

140moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

147moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

148+

149+-- |

150+-- Finds the value stored for a data constructor in the current environment.

151+-- This is a partial function, but if an invalid type has reached this far then

152+-- something has gone wrong in typechecking.

153+--

154+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)

155+lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

156+

157+-- |

158+-- Checks whether a data constructor is the only constructor for that type, used

159+-- to simplify the check when generating code for binders.

160+--

161+isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

162+isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

163+ where

164+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int

165+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

166+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)

167+ typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)

168+ typeConstructor _ = error "Invalid argument to isOnlyConstructor"

169+

170+-- |

171+-- Checks whether a data constructor is for a newtype.

172+--

173+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

174+isNewtypeConstructor e ctor = case lookupConstructor e ctor of

175+ (Newtype, _, _) -> True

176+ (Data, _, _) -> False

177+

178+-- |

179+-- Checks the number of arguments a data constructor accepts.

180+--

181+getConstructorArity :: Environment -> Qualified ProperName -> Int

182+getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e

183+ where

184+ go :: Type -> Int

185+ go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

186+ go (ForAll _ ty _) = go ty

187+ go _ = 0

188+

189+-- |

190+-- Checks whether a data constructor has no arguments, for example, `Nothing`.

191+--

192+isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

193+isNullaryConstructor e = (== 0) . getConstructorArity e

src/Language/PureScript/CodeGen/Externs.hs+5−1

@@ -24,6 +24,7 @@ import qualified Data.Map as M

24

25import Control.Monad.Writer

26

27+import Language.PureScript.CodeGen.Common

27import Language.PureScript.TypeClassDictionaries

28import Language.PureScript.TypeClassDictionaries

28import Language.PureScript.Declarations

29import Language.PureScript.Declarations

29import Language.PureScript.Pretty

30import Language.PureScript.Pretty

@@ -60,7 +61,10 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

60 printDctor dctor = case dctor `lookup` tys of

61 printDctor dctor = case dctor `lookup` tys of

61 Nothing -> Nothing

62 Nothing -> Nothing

62 Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)

63 Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)

64+ let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')

65+ then "newtype"

66+ else "data"

63− tell ["data " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

67+ tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

64 Just (_, TypeSynonym) ->

68 Just (_, TypeSynonym) ->

65 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

69 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

66 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

70 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

src/Language/PureScript/CodeGen/JS.hs+14−40

@@ -23,15 +23,13 @@ module Language.PureScript.CodeGen.JS (

23 identNeedsEscaping

24) where

25

26−import Data.Maybe (catMaybes, fromJust, fromMaybe)

26+import Data.Maybe (catMaybes, fromJust)

27import Data.Function (on)

28import Data.List (nub, (\\), delete, sortBy)

29

30import Control.Monad (replicateM, forM)

31import Control.Applicative

32

33−import qualified Data.Map as M

34−

35import Language.PureScript.Names

33import Language.PureScript.Names

36import Language.PureScript.Declarations

34import Language.PureScript.Declarations

37import Language.PureScript.Options

35import Language.PureScript.Options

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

106 js <- valueToJs opts mp e val

104 js <- valueToJs opts mp e val

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

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

108 return $ Just jss

106 return $ Just jss

107+declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =

108+ return $ Just $ [JSVariableIntroduction ctor (Just $

109+ JSObjectLiteral [("create",

110+ JSFunction Nothing ["value"]

111+ (JSBlock [JSReturn $ JSVar "value"]))])]

112+declToJs _ _ (DataDeclaration Newtype _ _ _) _ =

113+ error "newtype has multiple constructors"

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

114+declToJs _ mp (DataDeclaration Data _ _ ctors) e = do

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

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

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

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

112 in [ makeConstructor ctor (length tys)

117 in [ makeConstructor ctor (length tys)

@@ -211,6 +216,7 @@ valueToJs opts m e v@App{} = do

211 let (f, args) = unApp v []

216 let (f, args) = unApp v []

212 args' <- mapM (valueToJs opts m e) args

217 args' <- mapM (valueToJs opts m e) args

213 case f of

218 case f of

219+ Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')

214 Constructor name | getConstructorArity e name == length args ->

220 Constructor name | getConstructorArity e name == length args ->

215 return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'

221 return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'

216 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f

222 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f

@@ -343,6 +349,10 @@ binderToJs _ _ varName done (BooleanBinder False) =

343 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

349 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

344binderToJs _ _ varName done (VarBinder ident) =

350binderToJs _ _ varName done (VarBinder ident) =

345 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

351 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

352+binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =

353+ case bs of

354+ [b] -> binderToJs m e varName done b

355+ _ -> error "binder for newtype constructor should have a single argument"

346binderToJs m e varName done (ConstructorBinder ctor bs) = do

356binderToJs m e varName done (ConstructorBinder ctor bs) = do

347 js <- go 0 done bs

357 js <- go 0 done bs

348 if isOnlyConstructor e ctor

358 if isOnlyConstructor e ctor

@@ -395,39 +405,3 @@ binderToJs m e varName done (NamedBinder ident binder) = do

395 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

405 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

396binderToJs m e varName done (PositionedBinder _ binder) =

406binderToJs m e varName done (PositionedBinder _ binder) =

397 binderToJs m e varName done binder

407 binderToJs m e varName done binder

398−

399−-- |

400−-- Finds the value stored for a data constructor in the current environment.

401−-- This is a partial function, but if an invalid type has reached this far then

402−-- something has gone wrong in typechecking.

403−--

404−lookupConstructor :: Environment -> Qualified ProperName -> (ProperName, Type)

405−lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

406−

407−-- |

408−-- Checks whether a data constructor is the only constructor for that type, used

409−-- to simplify the check when generating code for binders.

410−--

411−isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

412−isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

413− where

414− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

415− typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

416− typeConstructor _ = error "Invalid argument to isOnlyConstructor"

417−

418−-- |

419−-- Checks the number of arguments a data constructor accepts.

420−--

421−getConstructorArity :: Environment -> Qualified ProperName -> Int

422−getConstructorArity e = go . snd . lookupConstructor e

423− where

424− go :: Type -> Int

425− go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

426− go (ForAll _ ty _) = go ty

427− go _ = 0

428−

429−-- |

430−-- Checks whether a data constructor has no arguments, for example, `Nothing`.

431−--

432−isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

433−isNullaryConstructor e = (== 0) . getConstructorArity e

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+3−3

@@ -118,9 +118,9 @@ instance Eq DeclarationRef where

118--

119data Declaration

120 -- |

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

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

122 --

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

123+ = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]

124 -- |

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

126 --

@@ -814,7 +814,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)

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

816 where

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

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

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

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

src/Language/PureScript/Environment.hs+18−1

@@ -41,7 +41,7 @@ data Environment = Environment {

41 -- |

42 -- Data constructors currently in scope, along with their associated data type constructors

43 --

44− , dataConstructors :: M.Map (Qualified ProperName) (ProperName, Type)

44+ , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type)

45 -- |

46 -- Type synonyms currently in scope

47 --

@@ -138,6 +138,23 @@ data TypeKind

138 --

139 | LocalTypeVariable deriving (Show, Eq, Data, Typeable)

140

141+-- |

142+-- The type ('data' or 'newtype') of a data type declaration

143+--

144+data DataDeclType

145+ -- |

146+ -- A standard data constructor

147+ --

148+ = Data

149+ -- |

150+ -- A newtype constructor

151+ --

152+ | Newtype deriving (Eq, Ord, Data, Typeable)

153+

154+instance Show DataDeclType where

155+ show Data = "data"

156+ show Newtype = "newtype"

157+

141-- |

158-- |

142-- Construct a ProperName in the Prim module

159-- Construct a ProperName in the Prim module

143--

160--

src/Language/PureScript/Parser/Common.hs+1

@@ -31,6 +31,7 @@ import Language.PureScript.Names

31--

32reservedPsNames :: [String]

33reservedPsNames = [ "data"

34+ , "newtype"

34 , "type"

35 , "type"

35 , "foreign"

36 , "foreign"

36 , "import"

37 , "import"

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

@@ -48,13 +48,13 @@ sourcePos = toSourcePos <$> P.getPosition

48

49parseDataDeclaration :: P.Parsec String ParseState Declaration

50parseDataDeclaration = do

51− reserved "data"

51+ dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)

52 name <- indented *> properName

53 tyArgs <- many (indented *> identifier)

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 dtype 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+18−12

@@ -39,21 +39,21 @@ import Language.PureScript.TypeClassDictionaries

39import Language.PureScript.Environment

40import Language.PureScript.Errors

41

42−addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

42+addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

43−addDataType moduleName name args dctors ctorKind = do

43+addDataType moduleName dtype name args dctors ctorKind = do

44 env <- getEnv

45 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

46 forM_ dctors $ \(dctor, tys) ->

47 rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $

48− addDataConstructor moduleName name args dctor tys

48+ addDataConstructor moduleName dtype name args dctor tys

49

50−addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

50+addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

51−addDataConstructor moduleName name args dctor tys = do

51+addDataConstructor moduleName dtype name args dctor tys = do

52 env <- getEnv

53 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

54 let dctorTy = foldr function retTy tys

55 let polyType = mkForAll args dctorTy

56− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (name, polyType) (dataConstructors env) }

56+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }

57

58addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

59addTypeSynonym moduleName name args ty kind = do

@@ -111,19 +111,25 @@ 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 dtype name args dctors) : rest) = do

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

116+ when (dtype == Newtype) $ checkNewtype dctors

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

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

117− addDataType moduleName name args dctors ctorKind

118+ addDataType moduleName dtype name args dctors ctorKind

118 ds <- typeCheckAll mainModuleName moduleName rest

119 ds <- typeCheckAll mainModuleName moduleName rest

119 return $ d : ds

120 return $ d : ds

121+ where

122+ checkNewtype :: [(ProperName, [Type])] -> Check ()

123+ checkNewtype [(_, [ty])] = return ()

124+ checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"

125+ checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"

120typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

126typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

121 rethrow (strMsg "Error in data binding group" <>) $ do

127 rethrow (strMsg "Error in data binding group" <>) $ do

122 let syns = mapMaybe toTypeSynonym tys

128 let syns = mapMaybe toTypeSynonym tys

123 let dataDecls = mapMaybe toDataDecl tys

129 let dataDecls = mapMaybe toDataDecl tys

124− (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

130+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

125− forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->

131+ forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) ->

126− addDataType moduleName name args dctors ctorKind

132+ addDataType moduleName dtype name args dctors ctorKind

127 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) ->

133 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) ->

128 addTypeSynonym moduleName name args ty kind

134 addTypeSynonym moduleName name args ty kind

129 ds <- typeCheckAll mainModuleName moduleName rest

135 ds <- typeCheckAll mainModuleName moduleName rest

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

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

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

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

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

134 toTypeSynonym _ = Nothing

140 toTypeSynonym _ = Nothing

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

141+ toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)

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

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

137 toDataDecl _ = Nothing

143 toDataDecl _ = Nothing

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

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

src/Language/PureScript/TypeChecker/Types.hs+4−4

@@ -641,8 +641,8 @@ infer' v@(Constructor c) = do

641 env <- getEnv

642 case M.lookup c (dataConstructors env) of

643 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

644− Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

644+ Just (_, _, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

645− return $ TypedValue True v ty'

645+ return $ TypedValue True v ty'

646infer' (Case vals binders) = do

647 ts <- mapM infer vals

648 ret <- fresh

@@ -726,7 +726,7 @@ inferBinder val (VarBinder name) = return $ M.singleton name val

726inferBinder val (ConstructorBinder ctor binders) = do

727 env <- getEnv

728 case M.lookup ctor (dataConstructors env) of

729− Just (_, ty) -> do

729+ Just (_, _, ty) -> do

730 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty

731 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

732 go binders fn'

@@ -951,7 +951,7 @@ check' (Constructor c) ty = do

951 env <- getEnv

952 case M.lookup c (dataConstructors env) of

953 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

954− Just (_, ty1) -> do

954+ Just (_, _, ty1) -> do

955 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

956 _ <- subsumes Nothing repl ty

957 return $ TypedValue True (Constructor c) ty