purescript 0.4.17 → 0.4.17.1

raw patch · 6 files changed

+70/−42 lines, 6 files

Files

• prelude/prelude.purs +9/−5
• purescript.cabal +1/−1
• src/Language/PureScript/Sugar/Names.hs +4/−2
• src/Language/PureScript/Sugar/TypeClasses.hs +45/−28
• src/Language/PureScript/TypeChecker/Monad.hs +1/−1
• src/Language/PureScript/TypeChecker/Types.hs +10/−5

@@ -15,16 +15,20 @@   infixr 9 >>>   infixr 9 <<< -  class Category a where-    id :: forall t. a t t+  class Semigroupoid a where     (<<<) :: forall b c d. a c d -> a b c -> a b d -  (>>>) :: forall a b c d. (Category a) => a b c -> a c d -> a b d+  instance semigroupoidArr :: Semigroupoid (->) where+    (<<<) f g x = f (g x)++  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d   (>>>) f g = g <<< f +  class (Semigroupoid a) <= Category a where+    id :: forall t. a t t+   instance categoryArr :: Category (->) where     id x = x-    (<<<) f g x = f (g x)    infixr 0 $   infixl 0 #@@ -80,7 +84,7 @@     (>>=) :: forall a b. m a -> (a -> m b) -> m b    class (Applicative m, Bind m) <= Monad m-    +   return :: forall m a. (Monad m) => a -> m a   return = pure 

@@ -1,5 +1,5 @@ name: purescript-version: 0.4.17+version: 0.4.17.1 cabal-version: >=1.8 build-type: Custom license: MIT

@@ -41,10 +41,11 @@ -- The exported declarations from a module. -- data Exports = Exports+  {   -- |   -- The types exported from each module   ---  { exportedTypes :: [(ProperName, [ProperName])]+    exportedTypes :: [(ProperName, [ProperName])]   -- |   -- The classes exported from each module   --@@ -59,10 +60,11 @@ -- An imported environment for a particular module. This also contains the module's own members. -- data ImportEnvironment = ImportEnvironment+  {   -- |   -- Local names for types within a module mapped to to their qualified names   ---  { importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)+    importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)   -- |   -- Local names for data constructors within a module mapped to to their qualified names   --

@@ -25,14 +25,18 @@ import Language.PureScript.Sugar.CaseDeclarations import Language.PureScript.Environment import Language.PureScript.Errors+import Language.PureScript.Pretty.Types (prettyPrintTypeAtom) import Language.PureScript.CodeGen.Common (identToJs)  import qualified Language.PureScript.Constants as C  import Control.Applicative+import Control.Monad.Error import Control.Monad.State import Control.Arrow (first, second)-import Data.Maybe (catMaybes)+import Data.List ((\\))+import Data.Monoid ((<>))+import Data.Maybe (catMaybes, mapMaybe)  import qualified Data.Map as M @@ -53,8 +57,7 @@   return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss) desugarModule _ = error "Exports should have been elaborated in name desugaring" --- |--- Desugar type class and type class instance declarations+{- Desugar type class and type class instance declarations -- -- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations. -- Additional values are generated to access individual members of a dictionary, with the appropriate type.@@ -105,7 +108,7 @@ --     } --     sub: "" --   }---+-} desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration]) desugarDecl mn d@(TypeClassDeclaration name args implies members) = do   modify (M.insert (mn, name) d)@@ -115,7 +118,7 @@   dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared   return $ (Just $ TypeInstanceRef name, [d, dictDecl]) desugarDecl mn (PositionedDeclaration pos d) = do-  (dr, ds) <- desugarDecl mn d+  (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d   return (dr, map (PositionedDeclaration pos) ds) desugarDecl _ other = return (Nothing, [other]) @@ -154,41 +157,55 @@ unit = TypeApp tyObject REmpty  typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration-typeInstanceDictionaryDeclaration name mn deps className tys decls = do+typeInstanceDictionaryDeclaration name mn deps className tys decls =+  rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do   m <- get    -- Lookup the type arguments and member types for the type class   (TypeClassDeclaration _ args implies tyDecls) <- lift $     maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $       M.lookup (qualify mn className) m-  let instanceTys = map memberToNameAndType tyDecls -  -- Replace the type arguments with the appropriate types in the member types-  let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys-  -- Create values for the type instance members-  memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls-  -- Create the type of the dictionary-  -- The type is an object type, but depending on type instance dependencies, may be constrained.-  -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary-  -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no-  -- dependencies, we introduce an unnamed function parameter.-  let superclasses = ObjectLiteral-        [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))-        | (index, (superclass, suTyArgs)) <- zip [0..] implies-        , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs-        , let fieldName = mkSuperclassDictionaryName superclass index-        ]+  case mapMaybe declName tyDecls \\ mapMaybe declName decls of+    x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing+    [] -> do+    +      let instanceTys = map memberToNameAndType tyDecls -  let memberNames' = (C.__superclasses, superclasses) : memberNames-      dictTy = foldl TypeApp (TypeConstructor className) tys-      constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)-      dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'-  return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)+      -- Replace the type arguments with the appropriate types in the member types+      let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys+      -- Create values for the type instance members+      memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls+      -- Create the type of the dictionary+      -- The type is an object type, but depending on type instance dependencies, may be constrained.+      -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary+      -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no+      -- dependencies, we introduce an unnamed function parameter.+      let superclasses = ObjectLiteral+            [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))+            | (index, (superclass, suTyArgs)) <- zip [0..] implies+            , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs+            , let fieldName = mkSuperclassDictionaryName superclass index+            ]++      let memberNames' = (C.__superclasses, superclasses) : memberNames+          dictTy = foldl TypeApp (TypeConstructor className) tys+          constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)+          dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'+          +      return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)+     where +  declName :: Declaration -> Maybe Ident+  declName (PositionedDeclaration _ d) = declName d+  declName (ValueDeclaration ident _ _ _ _) = Just ident+  declName (TypeDeclaration ident _) = Just ident+  declName _ = Nothing +   memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)   memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do-    _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup ident tys'+    _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'     let memberValue = typeInstanceDictionaryEntryValue d     return (ident, memberValue)   memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do

@@ -143,7 +143,7 @@ getEnv = checkEnv <$> get  -- |--- Update the @Environment#+-- Update the @Environment@ -- putEnv :: (MonadState CheckState m) => Environment -> m () putEnv env = modify (\s -> s { checkEnv = env })

@@ -45,8 +45,8 @@ import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe) import qualified Data.Data as D import Data.Generics-       (everythingWithContext, mkM, everywhereM, everything, mkT,-        something, everywhere, mkQ)+       (everythingWithContext, mkM, everywhereM,+        everything, mkT, something, everywhere, mkQ) import Data.Generics.Extras  import Language.PureScript.Declarations@@ -253,7 +253,12 @@ -- Map a function over type annotations appearing inside a value -- overTypes :: (Type -> Type) -> Value -> Value-overTypes f = everywhere (mkT f)+overTypes f = everywhere (mkT g)+  where+  g :: Value -> Value+  g (TypedValue checkTy val t) = TypedValue checkTy val (f t)+  g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco+  g other = other  -- | -- Replace type class dictionary placeholders with inferred type class dictionaries@@ -883,7 +888,7 @@     Nothing -> throwError . strMsg $ "Unable to check type subsumption"     Just v'' -> return $ TypedValue True v'' ty' check' (SuperClassDictionary className tys) _ = do-  -- |+  {-   -- Here, we replace a placeholder for a superclass dictionary with a regular   -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the   -- correct super instance dictionaries in scope, and these are not available when the type class@@ -892,7 +897,7 @@   -- Note also that the first argument to TypeClassDictionary is False, meaning we _do not_ want   -- to consider superclass instances when searching for this dictionary - doing so might lead   -- to traversing a cycle in the instance graph.-  --+  -}   dicts <- getTypeClassDictionaries   return $ TypeClassDictionary False (className, tys) dicts check' (TypedValue checkType val ty1) ty2 = do