7913cf9 · rowtype-yoga/purescript-native

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

Merge pull request #510 from purescript/newtypes

Newtypes

commit7913cf9d9a71d09bfdf82aefbb25e3d0c2ed7d97 authorGary Burgess <gary.burgess@gmail.com> dateSun 27 Jul 2014, 19:17 (12 years ago) parent2dbd57d 169e4ad

16 files changed+157−74

compare with golang

unifiedsplit

docgen/Main.hs+4−4

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

107107 where

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

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

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

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

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

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

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

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

141141 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

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

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

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

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

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

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

176176getName :: P.Declaration -> String

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

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

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

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

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

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

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

examples/failing/NewtypeMultiArgs.pursnew file+3

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

1+module Main where

3+newtype Thing = Thing String Boolean

examples/failing/NewtypeMultiCtor.pursnew file+3

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

1+module Main where

3+newtype Thing = Thing String | Other

examples/passing/Newtype.pursnew file+22

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

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+newtype Thing = Thing String

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

1717

1818import Data.Char

1919import Data.List (intercalate)

20+import Data.Maybe (fromMaybe)

21+import Data.Function (on)

22+

23+import qualified Data.Map as M

24+

2025import Language.PureScript.Names

26+import Language.PureScript.Environment

27+import Language.PureScript.Types

2128

2229-- |

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

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

138145

139146moduleNameToJs :: ModuleName -> String

140147moduleNameToJs (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

2424

2525import Control.Monad.Writer

2626

27+import Language.PureScript.CodeGen.Common

2728import Language.PureScript.TypeClassDictionaries

2829import Language.PureScript.Declarations

2930import Language.PureScript.Pretty

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

6061 printDctor dctor = case dctor `lookup` tys of

6162 Nothing -> Nothing

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

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

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

65+ then "newtype"

66+ else "data"

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

6468 Just (_, TypeSynonym) ->

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

6670 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 (

2323 identNeedsEscaping

2424) where

2525

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

26+import Data.Maybe (catMaybes, fromJust)

2727import Data.Function (on)

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

2929

3030import Control.Monad (replicateM, forM)

3131import Control.Applicative

3232

33−import qualified Data.Map as M

34−

3533import Language.PureScript.Names

3634import Language.PureScript.Declarations

3735import Language.PureScript.Options

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

106104 js <- valueToJs opts mp e val

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

108106 return $ Just jss

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

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"

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

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

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

112117 in [ makeConstructor ctor (length tys)

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

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

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

213218 case f of

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

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

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

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

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

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

344350binderToJs _ _ varName done (VarBinder ident) =

345351 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"

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

347357 js <- go 0 done bs

348358 if isOnlyConstructor e ctor

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

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

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

397407 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

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

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

118118--

119119data Declaration

120120 -- |

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

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

122122 --

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

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

124124 -- |

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

126126 --

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

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

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

816816 where

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

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

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

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

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

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

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

4141 -- |

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

4343 --

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

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

4545 -- |

4646 -- Type synonyms currently in scope

4747 --

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

138138 --

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

140140

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+

141158-- |

142159-- Construct a ProperName in the Prim module

143160--

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

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

3131--

3232reservedPsNames :: [String]

3333reservedPsNames = [ "data"

34+ , "newtype"

3435 , "type"

3536 , "foreign"

3637 , "import"

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

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

4848

4949parseDataDeclaration :: P.Parsec String ParseState Declaration

5050parseDataDeclaration = do

51− reserved "data"

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

5252 name <- indented *> properName

5353 tyArgs <- many (indented *> identifier)

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

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

3939import Language.PureScript.Environment

4040import Language.PureScript.Errors

4141

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

43−addDataType moduleName name args dctors ctorKind = do

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

43+addDataType moduleName dtype name args dctors ctorKind = do

4444 env <- getEnv

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

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

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

48− addDataConstructor moduleName name args dctor tys

48+ addDataConstructor moduleName dtype name args dctor tys

4949

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

51−addDataConstructor moduleName name args dctor tys = do

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

51+addDataConstructor moduleName dtype name args dctor tys = do

5252 env <- getEnv

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

5454 let dctorTy = foldr function retTy tys

5555 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) }

5757

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

5959addTypeSynonym moduleName name args ty kind = do

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

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

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

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

117− addDataType moduleName name args dctors ctorKind

118+ addDataType moduleName dtype name args dctors ctorKind

118119 ds <- typeCheckAll mainModuleName moduleName rest

119120 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"

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

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

122128 let syns = mapMaybe toTypeSynonym tys

123129 let dataDecls = mapMaybe toDataDecl tys

124− (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) ->

126− addDataType moduleName name args dctors ctorKind

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

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

132+ addDataType moduleName dtype name args dctors ctorKind

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

128134 addTypeSynonym moduleName name args ty kind

129135 ds <- typeCheckAll mainModuleName moduleName rest

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

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

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

134140 toTypeSynonym _ = Nothing

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

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

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

137143 toDataDecl _ = Nothing

138144typeCheckAll 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

641641 env <- getEnv

642642 case M.lookup c (dataConstructors env) of

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

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

645− return $ TypedValue True v ty'

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

645+ return $ TypedValue True v ty'

646646infer' (Case vals binders) = do

647647 ts <- mapM infer vals

648648 ret <- fresh

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

726726inferBinder val (ConstructorBinder ctor binders) = do

727727 env <- getEnv

728728 case M.lookup ctor (dataConstructors env) of

729− Just (_, ty) -> do

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

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

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

732732 go binders fn'

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

951951 env <- getEnv

952952 case M.lookup c (dataConstructors env) of

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

954− Just (_, ty1) -> do

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

955955 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

956956 _ <- subsumes Nothing repl ty

957957 return $ TypedValue True (Constructor c) ty