packages feed

purescript 0.4.16 → 0.4.17

raw patch · 19 files changed

+298/−107 lines, 19 files

Files

docgen/Main.hs view
@@ -92,7 +92,7 @@   matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'   matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'   matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'-  matches (P.TypeClassDeclaration ident _ _) (P.TypeClassRef ident') = ident == ident'+  matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'   matches (P.PositionedDeclaration _ d) r = d `matches` r   matches _ _ = False @@ -124,8 +124,11 @@ renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do   let typeName = P.runProperName name ++ " " ++ unwords args   atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty-renderDeclaration n exps (P.TypeClassDeclaration name args ds) = do-  atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"+renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do+  let impliesText = case implies of+                      [] -> ""+                      is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "+  atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"   mapM_ (renderDeclaration (n + 2) exps) ds renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do   let constraintsText = case constraints of@@ -142,7 +145,7 @@ getName (P.DataDeclaration name _ _) = P.runProperName name getName (P.ExternDataDeclaration name _) = P.runProperName name getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name-getName (P.TypeClassDeclaration name _ _) = P.runProperName name+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name getName (P.TypeInstanceDeclaration name _ _ _ _) = show name getName (P.PositionedDeclaration _ d) = getName d getName _ = error "Invalid argument to getName"
prelude/prelude.purs view
@@ -8,7 +8,7 @@    on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c   on f g x y = g x `f` g y-  +   asTypeOf :: forall a. a -> a -> a   asTypeOf x _ = x @@ -59,10 +59,12 @@    infixl 4 <*> -  class Applicative f where-    pure :: forall a. a -> f a+  class (Functor f) <= Apply f where     (<*>) :: forall a b. f (a -> b) -> f a -> f b +  class (Apply f) <= Applicative f where+    pure :: forall a. a -> f a+   liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b   liftA1 f a = pure f <*> a @@ -74,10 +76,14 @@    infixl 1 >>= -  class Monad m where-    return :: forall a. a -> m a+  class (Apply m) <= Bind m where     (>>=) :: 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+   liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b   liftM1 f a = do     a' <- a@@ -187,12 +193,19 @@    data Ordering = LT | GT | EQ +  instance eqOrdering :: Eq Ordering where+    (==) LT LT = true+    (==) GT GT = true+    (==) EQ EQ = true+    (==) _  _  = false+    (/=) x y = not (x == y)+   instance showOrdering :: Show Ordering where     show LT = "LT"     show GT = "GT"     show EQ = "EQ" -  class Ord a where+  class (Eq a) <= Ord a where     compare :: a -> a -> Ordering    infixl 4 <@@ -332,13 +345,25 @@     (||) = boolOr     not = boolNot +  infixr 5 <>++  class Semigroup a where+    (<>) :: a -> a -> a++  foreign import concatString+    "function concatString(s1) {\+    \  return function(s2) {\+    \    return s1 + s2;\+    \  };\+    \}" :: String -> String -> String++  instance semigroupString :: Semigroup String where+    (<>) = concatString+   infixr 5 ++ -  foreign import (++) "function $plus$plus(s1) {\-                      \  return function(s2) {\-                      \    return s1 + s2;\-                      \  };\-                      \}" :: String -> String -> String+  (++) :: forall s. (Semigroup s) => s -> s -> s+  (++) = (<>)  module Data.Eq where @@ -355,20 +380,20 @@    foreign import data Eff :: # ! -> * -> * -  foreign import retEff "function retEff(a) {\-                        \  return function() {\-                        \    return a;\-                        \  };\-                        \}" :: forall e a. a -> Eff e a--  foreign import bindEff "function bindEff(a) {\-                         \  return function(f) {\-                         \    return function() {\-                         \      return f(a())();\-                         \    };\+  foreign import returnE "function returnE(a) {\+                         \  return function() {\+                         \    return a;\                          \  };\-                         \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b+                         \}" :: forall e a. a -> Eff e a +  foreign import bindE "function bindE(a) {\+                       \  return function(f) {\+                       \    return function() {\+                       \      return f(a())();\+                       \    };\+                       \  };\+                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b+   type Pure a = forall e. Eff e a    foreign import runPure "function runPure(f) {\@@ -378,13 +403,16 @@   instance functorEff :: Functor (Eff e) where     (<$>) = liftA1 -  instance applicativeEff :: Applicative (Eff e) where-    pure = return+  instance applyEff :: Apply (Eff e) where     (<*>) = ap -  instance monadEff :: Monad (Eff e) where-    return = retEff-    (>>=) = bindEff+  instance applicativeEff :: Applicative (Eff e) where+    pure = returnE++  instance bindEff :: Bind (Eff e) where+    (>>=) = bindE++  instance monadEff :: Monad (Eff e)    foreign import untilE "function untilE(f) {\                         \  return function() {\
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.4.16+version: 0.4.17 cabal-version: >=1.8 build-type: Custom license: MIT
src/Language/PureScript/CodeGen/Externs.hs view
@@ -77,10 +77,12 @@     exportToPs (TypeClassRef className) =       case Qualified (Just moduleName) className `M.lookup` typeClasses env of         Nothing -> error $ show className ++ " has no type class definition in exportToPs"-        Just (args, members) -> do-          tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]+        Just (args, members, implies) -> do+          let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "+          tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]           forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->             tell [ "  " ++ show member ++ " :: " ++ prettyPrintType ty ]+     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) $ typeClassDictionaries env
src/Language/PureScript/CodeGen/JS.hs view
@@ -144,7 +144,7 @@ valueToJs _ m _ (Var ident) = varToJs m ident valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val-valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"+valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced" valueToJs _ _ _ _ = error "Invalid argument to valueToJs"  -- |
src/Language/PureScript/Constants.hs view
@@ -146,6 +146,9 @@ monadEffDictionary :: String monadEffDictionary = "monadEff" +bindEffDictionary :: String+bindEffDictionary = "bindEff"+ numNumber :: String numNumber = "numNumber" @@ -167,6 +170,9 @@ boolLikeBoolean :: String boolLikeBoolean = "boolLikeBoolean" +semigroupString :: String+semigroupString = "semigroupString"+ -- Main module  main :: String@@ -176,6 +182,9 @@  _ps :: String _ps = "_ps"++__superclasses :: String+__superclasses = "__superclasses"  -- Modules
src/Language/PureScript/Declarations.hs view
@@ -158,9 +158,9 @@   --   | ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)   -- |-  -- A type class declaration (name, argument, member declarations)+  -- A type class declaration (name, argument, implies, member declarations)   ---  | TypeClassDeclaration ProperName [String] [Declaration]+  | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]   -- |   -- A type instance declaration (name, dependencies, class name, instance types, member   -- declarations)@@ -329,10 +329,15 @@   -- |   -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these   -- placeholders will be replaced with actual expressions representing type classes dictionaries which-  -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and+  -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look+  -- at superclass implementations when searching for a dictionary, the type class name and   -- instance type, and the type class dictionaries in scope.   ---  | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]+  | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]+  -- |+  -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking+  --+  | SuperClassDictionary (Qualified ProperName) [Type]   -- |   -- A value with source position information   --
src/Language/PureScript/Environment.hs view
@@ -53,7 +53,7 @@   -- |   -- Type classes   ---  , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])+  , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])   } deriving (Show)  -- |
src/Language/PureScript/Optimizer.hs view
@@ -66,7 +66,6 @@   , inlineOperator (C.$) $ \f x -> JSApp f [x]   , inlineOperator (C.#) $ \x f -> JSApp f [x]   , inlineOperator (C.!!) $ flip JSIndexer-  , inlineOperator (C.++) $ JSBinary Add   , inlineCommonOperators ])  untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
src/Language/PureScript/Optimizer/Inliner.hs view
@@ -110,6 +110,8 @@   , binary C.eqBoolean (C.==) EqualTo   , binary C.eqBoolean (C./=) NotEqualTo +  , binary C.semigroupString (C.++) Add+   , binaryFunction C.bitsNumber C.shl ShiftLeft   , binaryFunction C.bitsNumber C.shr ShiftRight   , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
src/Language/PureScript/Optimizer/MagicDo.hs view
@@ -74,10 +74,10 @@     JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []   convert other = other   -- Check if an expression represents a monomorphic call to >>= for the Eff monad-  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True+  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True   isBind _ = False   -- Check if an expression represents a monomorphic call to return for the Eff monad-  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True+  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True   isReturn _ = False   -- Check if an expression represents the polymorphic >>= function   isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&@@ -101,11 +101,11 @@                                                                    name == name' = True   isEffFunc _ _ = False   -- Check if an expression represents the Monad Eff dictionary-  isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == C.monadEffDictionary = True-  isEffDict (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&-                                                                                          _ps == C._ps &&-                                                                                          prop == C.monadEffDictionary = True-  isEffDict _ = False+  isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True+  isEffDict name (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&+                                                                                               _ps == C._ps &&+                                                                                               prop == name = True+  isEffDict _ _ = False   -- Remove __do function applications which remain after desugaring   undo :: JS -> JS   undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
src/Language/PureScript/Parser/Declarations.hs view
@@ -144,12 +144,17 @@ parseTypeClassDeclaration :: P.Parsec String ParseState Declaration parseTypeClassDeclaration = do   reserved "class"+  implies <- P.option [] $ do+    indented+    implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))+    reservedOp "<="+    return implies   className <- indented *> properName   idents <- P.many (indented *> identifier)   members <- P.option [] . P.try $ do     indented *> reserved "where"-    mark (P.many (same *> parseTypeDeclaration))-  return $ TypeClassDeclaration className idents members+    mark (P.many (same *> positioned parseTypeDeclaration))+  return $ TypeClassDeclaration className idents implies members  parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration parseTypeInstanceDeclaration = do@@ -164,14 +169,17 @@   ty <- P.many (indented *> parseTypeAtom)   members <- P.option [] . P.try $ do     indented *> reserved "where"-    mark (P.many (same *> parseValueDeclaration))+    mark (P.many (same *> positioned parseValueDeclaration))   return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members +positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration+positioned d = PositionedDeclaration <$> sourcePos <*> d+ -- | -- Parse a single declaration -- parseDeclaration :: P.Parsec String ParseState Declaration-parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice+parseDeclaration = positioned (P.choice                    [ parseDataDeclaration                    , parseTypeDeclaration                    , parseTypeSynonymDeclaration@@ -181,7 +189,7 @@                    , parseImportDeclaration                    , parseTypeClassDeclaration                    , parseTypeInstanceDeclaration-                   ] P.<?> "declaration"+                   ]) P.<?> "declaration"  parseLocalDeclaration :: P.Parsec String ParseState Declaration parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
src/Language/PureScript/Pretty/Types.hs view
@@ -39,7 +39,7 @@   match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"   match (TypeConstructor ctor) = Just $ show ctor   match (TUnknown (Unknown u)) = Just $ 'u' : show u-  match (Skolem s _) = Just $ 's' : show s+  match (Skolem name s _) = Just $ name ++ show s   match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty   match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"   match REmpty = Just "()"
src/Language/PureScript/Pretty/Values.hs view
@@ -73,7 +73,8 @@     , withIndent $ prettyPrintMany prettyPrintDoNotationElement els     , currentIndent     ]-  match (TypeClassDictionary _ _) = return "<<dict>>"+  match (TypeClassDictionary _ _ _) = return "<<dict>>"+  match (SuperClassDictionary _ _) = return "<<superclass dict>>"   match (TypedValue _ val _) = prettyPrintValue' val   match (PositionedValue _ val) = prettyPrintValue' val   match _ = mzero
src/Language/PureScript/Sugar/Names.hs view
@@ -185,6 +185,8 @@   go (TypeSynonymDeclaration name ps ty) =       rethrow (strMsg ("Error in type synonym " ++ show name) <>) $         TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty+  go (TypeClassDeclaration className args implies ds) =+    TypeClassDeclaration className args <$> updateConstraints Nothing implies <*> mapM go ds   go (TypeInstanceDeclaration name cs cn ts ds) =       TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds   go (ExternInstanceDeclaration name cs cn ts) =@@ -209,7 +211,7 @@     bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =       (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)     bindFunctionArgs pb other = return (pb, other)-    +     bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)     bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c) @@ -245,7 +247,7 @@   updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)   updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)   updateType pos t = return (pos, t)-  +   updateType' :: Data d => d -> Either ErrorStack d   updateType' = everywhereWithContextM' Nothing (mkS updateType) @@ -301,9 +303,13 @@    -- Add a declaration from a module to the global export environment   addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment-  addDecl mn env (TypeClassDeclaration tcn _ ds) = do+  addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do     env' <- addTypeClass env mn tcn-    foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds+    foldM go env' ds+    where+    go env'' (TypeDeclaration name _) = addValue env'' mn name+    go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d+    go _ _ = error "Invalid declaration in TypeClassDeclaration"   addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)   addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []   addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []@@ -389,14 +395,14 @@ resolveImports env (Module currentModule decls _) =   foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)   where-  +   -- 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, Maybe ExplicitImports, Maybe ModuleName)   scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls) -  resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment  +  resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment   resolveImport' imp (mn, (pos, explImports, 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 explImports
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -27,6 +27,8 @@ import Language.PureScript.Errors import Language.PureScript.CodeGen.Common (identToJs) +import qualified Language.PureScript.Constants as C+ import Control.Applicative import Control.Monad.State import Control.Arrow (first, second)@@ -34,7 +36,7 @@  import qualified Data.Map as M -type MemberMap = M.Map (ModuleName, ProperName) ([String], [(Ident, Type)])+type MemberMap = M.Map (ModuleName, ProperName) Declaration  type Desugar = StateT MemberMap (Either ErrorStack) @@ -70,6 +72,14 @@ --   instance fooArray :: (Foo a) => Foo [a] where --     foo = map foo --+--   {- Superclasses -}+--+--   class (Foo a) <= Sub a where+--     sub :: a+--+--   instance subString :: Sub String where+--     sub = ""+-- -- becomes -- --   type Foo a = { foo :: a -> a }@@ -84,11 +94,22 @@ --   fooArray :: forall a. (Foo a) => Foo [a] --   fooArray = { foo: map foo } --+--   {- Superclasses -}+--+--   ...+--+--   subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }+--   subString _ = {+--     __superclasses: {+--       "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>+--     }+--     sub: ""+--   }+-- desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])-desugarDecl mn d@(TypeClassDeclaration name args members) = do-  let tys = map memberToNameAndType members-  modify (M.insert (mn, name) (args, tys))-  return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)+desugarDecl mn d@(TypeClassDeclaration name args implies members) = do+  modify (M.insert (mn, name) d)+  return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do   desugared <- lift $ desugarCases members   dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared@@ -107,10 +128,16 @@ identToProperty (Ident name) = name identToProperty (Op op) = op -typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration-typeClassDictionaryDeclaration name args members =-  TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty))+typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration+typeClassDictionaryDeclaration name args implies members =+  let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)+                                                        | (index, (superclass, tyArgs)) <- zip [0..] implies+                                                        , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs+                                                        , let fieldName = mkSuperclassDictionaryName superclass index+                                                        ], REmpty)) +  in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList ((C.__superclasses, superclassesType) : map (first identToProperty . memberToNameAndType) members, REmpty))+ typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =   ExternDeclaration TypeClassAccessorImport ident@@ -120,13 +147,21 @@   PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition" +mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String+mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index++unit :: Type+unit = TypeApp tyObject REmpty+ typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls = do   m <- get    -- Lookup the type arguments and member types for the type class-  (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right-                        $ M.lookup (qualify mn className) m+  (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@@ -137,20 +172,26 @@   -- 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 dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes, REmpty))+  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+      dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'   return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)   where-  unit :: Type-  unit = TypeApp tyObject REmpty    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'     let memberValue = typeInstanceDictionaryEntryValue d     return (ident, memberValue)-  memberToNameAndValue tys' (PositionedDeclaration pos d) = do+  memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do     (ident, val) <- memberToNameAndValue tys' d     return (ident, PositionedValue pos val)   memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
src/Language/PureScript/TypeChecker.hs view
@@ -73,10 +73,14 @@   env <- getEnv   putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) }) -addTypeClass :: ModuleName -> ProperName -> [String] -> [Declaration] -> Check ()-addTypeClass moduleName pn args ds =-  let members = map (\(TypeDeclaration ident ty) -> (ident, ty)) ds in-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members) (typeClasses . checkEnv $ st) } }+addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()+addTypeClass moduleName pn args implies ds =+  let members = map toPair ds in+  modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }+  where+  toPair (TypeDeclaration ident ty) = (ident, ty)+  toPair (PositionedDeclaration _ d) = toPair d+  toPair _ = error "Invalid declaration in TypeClassDeclaration"  addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check () addTypeClassDictionaries entries =@@ -186,8 +190,8 @@                            ]   ds <- typeCheckAll mainModuleName currentModule rest   return $ d : ds-typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do-  addTypeClass moduleName pn args tys+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do+  addTypeClass moduleName pn args implies tys   ds <- typeCheckAll mainModuleName moduleName rest   return $ d : ds typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
src/Language/PureScript/TypeChecker/Types.hs view
@@ -116,7 +116,7 @@   unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do     t3 `unifyTypes` t5     t4 `unifyTypes` t6-  unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()+  unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()   unifyTypes' r1@RCons{} r2 = unifyRows r1 r2   unifyTypes' r1 r2@RCons{} = unifyRows r1 r2   unifyTypes' r1@REmpty r2 = unifyRows r1 r2@@ -155,7 +155,7 @@     unifyRows' row r others u'   unifyRows' [] REmpty [] REmpty = return ()   unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()-  unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()+  unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()   unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"  -- |@@ -261,9 +261,9 @@ replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value replaceTypeClassDictionaries mn = everywhereM' (mkM go)   where-  go (TypeClassDictionary constraint dicts) = do+  go (TypeClassDictionary trySuperclasses constraint dicts) = do     env <- getEnv-    entails env mn dicts constraint+    entails env mn dicts constraint trySuperclasses   go other = return other  -- |@@ -283,13 +283,17 @@   -- A dictionary which depends on other dictionaries   --   | DependentDictionaryValue (Qualified Ident) [DictionaryValue]+  -- |+  -- A subclass dictionary+  --+  | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer   deriving (Show, Ord, Eq)  -- | -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. ---entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))   where     sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]@@ -301,13 +305,16 @@     filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True     filterModule _ = False 	-    solve context' goal@(className, tys) =-      case go goal of-        [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)-        [dict] -> return (dictionaryValueToValue dict)-        _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)+    solve context' (className, tys) trySuperclasses =+      let+        dicts = go trySuperclasses className tys+      in case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of+           [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)+           [_] -> return $ dictionaryValueToValue $ head dicts+           _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)       where-	  go (className', tys') =+	  go trySuperclasses' className' tys' =+	    -- Look for regular type instances 	    [ mkDictionary (canonicalizeDictionary tcd) args 	    | tcd <- context' 	    -- Make sure the type class name matches the one we are trying to satisfy@@ -315,14 +322,29 @@ 	    -- Make sure the type unifies with the type in the type instance definition 	    , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd) 	    -- Solve any necessary subgoals-	    , args <- solveSubgoals subst (tcdDependencies tcd) ]+	    , args <- solveSubgoals subst (tcdDependencies tcd) ] +++	+	    -- Look for implementations via superclasses+	    [ SubclassDictionaryValue suDict superclass index+	    | trySuperclasses'+	    , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)+	    -- Try each superclass+	    , (index, (superclass, suTyArgs)) <- zip [0..] implies+	    -- Make sure the type class name matches the superclass name+	    , className' == superclass+	    -- Make sure the types unify with the types in the superclass implication+	    , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs+	    -- Finally, satisfy the subclass constraint+	    , args' <- maybeToList $ mapM (applySubst subst . TypeVar) args+	    , suDict <- go True subclassName args' ]+	 	  -- Create dictionaries for subgoals which still need to be solved by calling go recursively 	  -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type 	  -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. 	  solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]] 	  solveSubgoals _ Nothing = return Nothing 	  solveSubgoals subst (Just subgoals) = do-	    dict <- mapM (go . second (map (replaceAllTypeVars subst))) subgoals+	    dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals 	    return $ Just dict 	  -- Make a dictionary from subgoal dictionaries by applying the correct function 	  mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue@@ -334,12 +356,45 @@ 	  dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName 	  dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral []) 	  dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)+	  dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =+	    App (Accessor (show superclassName ++ "_" ++ show index)+	                  (Accessor C.__superclasses (dictionaryValueToValue dict)))+	        (ObjectLiteral []) 	  -- Ensure that a substitution is valid 	  verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)] 	  verifySubstitution subst = do 	    let grps = groupBy ((==) `on` fst) subst 	    guard (all (pairwise (unifiesWith env) . map snd) grps) 	    return $ map head grps+	  -- Apply a substitution to a type+	  applySubst :: [(String, Type)] -> Type -> Maybe Type+	  applySubst subst = everywhereM (mkM replace)+	    where+	    replace (TypeVar v) = lookup v subst+	    replace other = Just other+	  -- Choose the simplest DictionaryValues from a list of candidates+	  -- The reason for this function is as follows:+	  -- When considering overlapping instances, we don't want to consider the same dictionary+	  -- to be an overlap of itself when obtained as a superclass of another class.+	  -- Observing that we probably don't want to select a superclass instance when an instance+	  -- is available directly, and that there is no way for a superclass instance to actually+	  -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries+	  -- obtained as superclass instances if there are simpler instances available.+	  chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]+	  chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of+	                                    [] -> ds+	                                    simple -> simple+	  isSimpleDictionaryValue SubclassDictionaryValue{} = False+	  isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds+	  isSimpleDictionaryValue _ = True+	  -- |+	  -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue+	  -- data constructors+	  --+	  dictTrace :: DictionaryValue -> DictionaryValue+	  dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts+	  dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict+	  dictTrace other = other  -- | -- Check all values in a list pairwise match a predicate@@ -355,7 +410,7 @@ unifiesWith :: Environment -> Type -> Type -> Bool unifiesWith _ (TUnknown _) _ = True unifiesWith _ _ (TUnknown _) = True-unifiesWith _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = True+unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2@@ -371,7 +426,7 @@ -- and return a substitution from type variables to types which makes the type heads unify. -- typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]-typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []+typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just [] typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)] typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2@@ -405,7 +460,7 @@     collectSkolems :: Type -> [SkolemScope]     collectSkolems = nub . everything (++) (mkQ [] collect)       where-      collect (Skolem _ scope) = [scope]+      collect (Skolem _ _ scope) = [scope]       collect _ = []   go _ scos = ([], scos)   findBindingScope :: SkolemScope -> Maybe Value@@ -454,7 +509,7 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do    dicts <- getTypeClassDictionaries    (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty-   return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')+   return (foldl App val (map (flip (TypeClassDictionary True) dicts) constraints), ty') instantiatePolyTypeWithUnknowns val ty = return (val, ty)  -- |@@ -578,7 +633,7 @@   case ty of     ConstrainedType constraints ty' -> do       dicts <- getTypeClassDictionaries-      return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'+      return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) dicts) constraints)) ty'     _ -> return $ TypedValue True (Var var) ty infer' v@(Constructor c) = do   env <- getEnv@@ -600,6 +655,9 @@ infer' (Let ds val) = do   (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer   return $ TypedValue True (Let ds' val') valTy+infer' (SuperClassDictionary className tys) = do+  dicts <- getTypeClassDictionaries+  return $ TypeClassDictionary False (className, tys) dicts infer' (TypedValue checkType val ty) = do   Just moduleName <- checkCurrentModule <$> get   kind <- liftCheck $ kindOf moduleName ty@@ -735,9 +793,20 @@ -- Skolemize a type variable by replacing its instances with fresh skolem constants -- skolemize :: String -> Int -> SkolemScope -> Type -> Type-skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)+skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)  -- |+-- This function has one purpose - to skolemize type variables appearing in a+-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the+-- only example of scoped type variables.+--+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value+skolemizeTypesInValue ident sko scope = everywhere (mkT go)+  where+  go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)+  go other = other++-- | -- Introduce skolem scope at every occurence of a ForAll -- introduceSkolemScope :: Type -> UnifyT Type Check Type@@ -766,7 +835,8 @@   scope <- newSkolemScope   sko <- newSkolemConstant   let sk = skolemize ident sko scope ty-  val' <- check val sk+  let skVal = skolemizeTypesInValue ident sko scope val+  val' <- check skVal sk   return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do   dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do@@ -812,6 +882,19 @@   case v' of     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+  -- declaration gets desugared.+  --+  -- 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   Just moduleName <- checkCurrentModule <$> get   kind <- liftCheck $ kindOf moduleName ty1@@ -883,7 +966,7 @@   go [] [] REmpty = return []   go [] [] u@(TUnknown _) = do u =?= REmpty                                return []-  go [] [] (Skolem _ _) | lax = return []+  go [] [] (Skolem _ _ _) | lax = return []   go [] ((p, _): _) _ | lax = return []                       | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))   go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))@@ -944,7 +1027,7 @@   checkFunctionApplication fn ty arg ret checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do   dicts <- getTypeClassDictionaries-  checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret+  checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "   ++ prettyPrintType fnTy   ++ " to argument " ++ prettyPrintValue arg@@ -987,7 +1070,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do   dicts <- getTypeClassDictionaries   _ <- subsumes' Nothing ty1 ty2-  return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)+  return . Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints) subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do   let     (ts1, r1') = rowToList r1
src/Language/PureScript/Types.hs view
@@ -66,7 +66,7 @@   -- |   -- A skolem constant   ---  | Skolem Int SkolemScope+  | Skolem String Int SkolemScope   -- |   -- An empty row   --