purescript 0.6.1.1 → 0.6.1.2

raw patch · 11 files changed

+78/−45 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/failing/TypeSynonyms4.purs +8/−0
• purescript.cabal +1/−1
• src/Language/PureScript/AST/Binders.hs +1/−1
• src/Language/PureScript/AST/Declarations.hs +4/−4
• src/Language/PureScript/AST/SourcePos.hs +19/−6
• src/Language/PureScript/CodeGen/Externs.hs +1/−1
• src/Language/PureScript/Errors.hs +3/−3
• src/Language/PureScript/Parser/Declarations.hs +20/−16
• src/Language/PureScript/Sugar/Names.hs +10/−10
• src/Language/PureScript/Sugar/Operators.hs +3/−3
• src/Language/PureScript/TypeChecker.hs +8/−0

@@ -0,0 +1,8 @@+module TypeSynonyms4 where++type F x y = x -> y++type G x = F x++f :: G String String -> String+f k = k "Done"

@@ -1,5 +1,5 @@ name: purescript-version: 0.6.1.1+version: 0.6.1.2 cabal-version: >=1.8 build-type: Simple license: MIT

@@ -68,7 +68,7 @@   -- |   -- A binder with source position information   ---  | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)+  | PositionedBinder SourceSpan Binder deriving (Show, D.Data, D.Typeable)  -- | -- Collect all names introduced in binders in an expression

@@ -57,7 +57,7 @@   -- |   -- A declaration reference with source position information   ---  | PositionedDeclarationRef SourcePos DeclarationRef+  | PositionedDeclarationRef SourceSpan DeclarationRef   deriving (Show, D.Data, D.Typeable)  instance Eq DeclarationRef where@@ -147,7 +147,7 @@   -- |   -- A declaration with source position information   ---  | PositionedDeclaration SourcePos Declaration+  | PositionedDeclaration SourceSpan Declaration   deriving (Show, D.Data, D.Typeable)  -- |@@ -324,7 +324,7 @@   -- |   -- A value with source position information   ---  | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)+  | PositionedValue SourceSpan Expr deriving (Show, D.Data, D.Typeable)  -- | -- An alternative in a case statement@@ -359,4 +359,4 @@   -- |   -- A do notation element with source position information   ---  | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)+  | PositionedDoNotationElement SourceSpan DoNotationElement deriving (Show, D.Data, D.Typeable)

@@ -23,13 +23,9 @@ -- data SourcePos = SourcePos   { -- |-    -- Source name-    ---    sourceName :: String-    -- |     -- Line number     ---  , sourcePosLine :: Int+    sourcePosLine :: Int     -- |     -- Column number     --@@ -37,4 +33,21 @@   } deriving (D.Data, D.Typeable)  instance Show SourcePos where-  show sp = sourceName sp ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)+  show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)++data SourceSpan = SourceSpan+  { -- |+    -- Source name+    --+    spanName :: String+    -- |+    -- Start of the span+    --+  , spanStart :: SourcePos+    -- End of the span+    --+  , spanEnd :: SourcePos+  } deriving (D.Data, D.Typeable)+  +instance Show SourceSpan where+  show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)

@@ -97,7 +97,7 @@      exportToPs (TypeInstanceRef ident) = do       let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =-            fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ M.elems $ typeClassDictionaries env+            fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) $ M.elems $ typeClassDictionaries env       let constraintsText = case fromMaybe [] deps of                               [] -> ""                               cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

@@ -56,7 +56,7 @@         -- |         -- Optional source position information         ---      , compileErrorPosition :: Maybe SourcePos+      , compileErrorPosition :: Maybe SourceSpan       }   deriving (Show) @@ -109,7 +109,7 @@ mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack mkErrorStack msg t = ErrorStack [CompileError msg t Nothing] -positionError :: SourcePos -> ErrorStack+positionError :: SourceSpan -> ErrorStack positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]  -- |@@ -121,7 +121,7 @@ -- | -- Rethrow an error with source position information ---rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a+rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a rethrowWithPosition pos = rethrow (positionError pos <>)  -- |

@@ -48,10 +48,15 @@ -- | -- Read source position information ---sourcePos :: P.Parsec s u SourcePos-sourcePos = toSourcePos <$> P.getPosition+withSourceSpan :: (SourceSpan -> a -> a) -> P.Parsec s u a -> P.Parsec s u a+withSourceSpan f p = do+  start <- P.getPosition+  x <- p+  end <- P.getPosition+  let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)+  return $ f sp x   where-  toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)+  toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)  kindedIdent :: P.Parsec String ParseState (String, Maybe Kind) kindedIdent = (, Nothing) <$> identifier@@ -165,11 +170,11 @@   parseDeclarationRef :: P.Parsec String ParseState DeclarationRef-parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>-  (ValueRef <$> parseIdent-   <|> do name <- properName-          dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)-          return $ maybe (TypeClassRef name) (TypeRef name) dctors)+parseDeclarationRef = withSourceSpan PositionedDeclarationRef $+  ValueRef <$> parseIdent+    <|> do name <- properName+           dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)+           return $ maybe (TypeClassRef name) (TypeRef name) dctors  parseTypeClassDeclaration :: P.Parsec String ParseState Declaration parseTypeClassDeclaration = do@@ -203,7 +208,7 @@   return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members  positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration-positioned d = PositionedDeclaration <$> sourcePos <*> d+positioned d = withSourceSpan PositionedDeclaration d  -- | -- Parse a single declaration@@ -222,10 +227,10 @@                    ]) P.<?> "declaration"  parseLocalDeclaration :: P.Parsec String ParseState Declaration-parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice+parseLocalDeclaration = positioned (P.choice                    [ parseTypeDeclaration                    , parseValueDeclaration-                   ] P.<?> "local declaration"+                   ] P.<?> "local declaration")  -- | -- Parse a module header and a collection of declarations@@ -374,10 +379,10 @@ -- Parse a value -- parseValue :: P.Parsec String ParseState Expr-parseValue = PositionedValue <$> sourcePos <*>+parseValue = withSourceSpan PositionedValue   (P.buildExpressionParser operators-   . C.buildPostfixParser postfixTable2-   $ indexersAndAccessors) P.<?> "expression"+    . C.buildPostfixParser postfixTable2+    $ indexersAndAccessors) P.<?> "expression"   where   indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom   postfixTable1 = [ parseAccessor@@ -439,8 +444,7 @@ -- Parse a binder -- parseBinder :: P.Parsec String ParseState Binder-parseBinder = PositionedBinder <$> sourcePos <*>-    P.buildExpressionParser operators parseBinderAtom P.<?> "expression"+parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")   where   operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]   parseBinderAtom :: P.Parsec String ParseState Binder

@@ -198,7 +198,7 @@   where   (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS -  updateDecl :: (Maybe SourcePos, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourcePos, [Ident]), Declaration)+  updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)   updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)   updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =     (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)@@ -216,7 +216,7 @@     (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)   updateDecl s d = return (s, d) -  updateValue :: (Maybe SourcePos, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourcePos, [Ident]), Expr)+  updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)   updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)   updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')   updateValue (pos, bound) (Let ds val') =@@ -234,12 +234,12 @@   updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)   updateValue s v = return (s, v) -  updateBinder :: (Maybe SourcePos, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourcePos, [Ident]), Binder)+  updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)   updateBinder (_, bound) v@(PositionedBinder pos _) = return ((Just pos, bound), v)   updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)   updateBinder s v = return (s, v) -  updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)+  updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourceSpan, [Ident]), CaseAlternative)   updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)    letBoundVariable :: Declaration -> Maybe Ident@@ -247,10 +247,10 @@   letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d   letBoundVariable _ = Nothing -  updateTypesEverywhere :: Maybe SourcePos -> Type -> Either ErrorStack Type+  updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type   updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)     where-    updateType :: Maybe SourcePos -> Type -> Either ErrorStack Type+    updateType :: Maybe SourceSpan -> Type -> Either ErrorStack Type     updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos     updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys     updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t@@ -269,7 +269,7 @@                             -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))                             -> (Exports -> a -> Bool)                             -> Qualified a-                            -> Maybe SourcePos+                            -> Maybe SourceSpan                             -> Either ErrorStack (Qualified a)   update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of     (Just qname', _) -> return qname'@@ -385,7 +385,7 @@ -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. ---findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) findImports = foldl (findImports' Nothing) M.empty   where   findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result@@ -403,10 +403,10 @@   -- A Map from module name to the source position for the import, the list of imports from that   -- module (where Nothing indicates everything is to be imported), and optionally a qualified name   -- for the module-  scope :: M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)+  scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)   scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls) -  resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment+  resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment   resolveImport' imp (mn, (pos, typ, impQual)) = do     modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env     positioned $ resolveImport currentModule mn modExports imp impQual typ

@@ -76,15 +76,15 @@   go (Parens val) = val   go val = val -collectFixities :: Module -> [(Qualified Ident, SourcePos, Fixity)]+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)] collectFixities (Module moduleName ds _) = concatMap collect ds   where-  collect :: Declaration -> [(Qualified Ident, SourcePos, Fixity)]+  collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]   collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]   collect FixityDeclaration{} = error "Fixity without srcpos info"   collect _ = [] -ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack ()+ensureNoDuplicates :: [(Qualified Ident, SourceSpan)] -> Either ErrorStack () ensureNoDuplicates m = go $ sortBy (compare `on` fst) m   where   go [] = return ()

@@ -53,6 +53,7 @@ addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check () addDataConstructor moduleName dtype name args dctor tys = do   env <- getEnv+  mapM_ checkTypeSynonyms tys   let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)   let dctorTy = foldr function retTy tys   let polyType = mkForAll args dctorTy@@ -61,6 +62,7 @@ addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check () addTypeSynonym moduleName name args ty kind = do   env <- getEnv+  checkTypeSynonyms ty   putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)                , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } @@ -105,6 +107,12 @@   return () checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2 checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))++-- |+-- Check that type synonyms are fully-applied in a type+--+checkTypeSynonyms :: Type -> Check ()+checkTypeSynonyms = void . replaceAllTypeSynonyms  -- | -- Type check all declarations in a module