diff --git a/prelude/prelude.purs b/prelude/prelude.purs --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -8,6 +8,9 @@ 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 infixr 9 >>> infixr 9 <<< diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.4.15.1 +version: 0.4.16 cabal-version: >=1.8 build-type: Custom license: MIT diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs --- a/src/Language/PureScript/CodeGen/Common.hs +++ b/src/Language/PureScript/CodeGen/Common.hs @@ -32,7 +32,6 @@ identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name identToJs (Ident name) = concatMap identCharToString name identToJs (Op op) = concatMap identCharToString op -identToJs (Escaped name) = name -- | -- Attempts to find a human-readable name for a symbol, if none has been specified returns the @@ -129,6 +128,13 @@ , "while" , "with" , "yield" ] + +-- | +-- Test if a string is a valid JS identifier (may return false negatives) +-- +isIdent :: String -> Bool +isIdent s@(first : rest) | not (nameIsJsReserved s) && isAlpha first && all isAlphaNum rest = True +isIdent _ = False moduleNameToJs :: ModuleName -> String moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -19,7 +19,8 @@ module AST, declToJs, moduleToJs, - wrapExportsContainer + wrapExportsContainer, + isIdent ) where import Data.Maybe (fromMaybe, mapMaybe) @@ -90,7 +91,7 @@ -- module. -- exportToJs :: DeclarationRef -> [JS] -exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName) +exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName) exportToJs (ValueRef name) = [export name] exportToJs (TypeInstanceRef name) = [export name] exportToJs _ = [] @@ -115,10 +116,13 @@ -- indexer is returned. -- accessor :: Ident -> JS -> JS -accessor (Ident name) | nameIsJsReserved name = JSIndexer (JSStringLiteral name) +accessor (Ident prop) = accessorString prop accessor (Op op) = JSIndexer (JSStringLiteral op) -accessor ident = JSAccessor (identToJs ident) +accessorString :: String -> JS -> JS +accessorString prop | isIdent prop = JSAccessor prop + | otherwise = JSIndexer (JSStringLiteral prop) + -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. -- @@ -132,13 +136,14 @@ valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values) valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el) -valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val) +valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val) valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg] valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) [] valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)]) valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)]) 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 _ _ _ _ = error "Invalid argument to valueToJs" @@ -198,7 +203,7 @@ let (pairs, _) = rowToList row in - typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs + typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (accessorString prop val) ty') pairs argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"] argumentCheck val (ForAll _ ty' _) = argumentCheck val ty' argumentCheck _ _ = [] @@ -283,7 +288,7 @@ propVar <- fresh done'' <- go done' bs' js <- binderToJs m e propVar done'' binder - return (JSVariableIntroduction propVar (Just (JSAccessor prop (JSVar varName))) : js) + return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js) binderToJs m e varName done (ArrayBinder bs) = do js <- go done 0 bs return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing] diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -19,8 +19,6 @@ import Data.Data - - -- | -- Built-in unary operators -- diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -102,11 +102,7 @@ -- | -- A type class dictionary, generated during desugaring of type class declarations -- - | TypeInstanceDictionaryValue - -- | - -- A type instance member, generated during desugaring of type class declarations - -- - | TypeInstanceMember deriving (Show, Eq, Data, Typeable) + | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable) -- | -- The kinds of a type diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -19,7 +19,6 @@ import Data.List import Data.Data -import Data.Function (on) -- | -- Names for value identifiers @@ -32,27 +31,11 @@ -- | -- A symbolic name for an infix operator -- - | Op String - -- | - -- An escaped name - -- - | Escaped String deriving (Data, Typeable) + | Op String deriving (Eq, Ord, Data, Typeable) instance Show Ident where show (Ident s) = s show (Op op) = '(':op ++ ")" - show (Escaped s) = s - -instance Eq Ident where - Ident s1 == Ident s2 = s1 == s2 - Op s1 == Op s2 = s1 == s2 - Escaped s1 == Escaped s2 = s1 == s2 - Ident s1 == Escaped s2 = s1 == s2 - Escaped s1 == Ident s2 = s1 == s2 - _ == _ = False - -instance Ord Ident where - compare = compare `on` show -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -227,7 +227,7 @@ parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue) parseIdentifierAndValue :: P.Parsec String ParseState (String, Value) -parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon) +parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon) <*> (C.indented *> parseValue) parseAbs :: P.Parsec String ParseState Value @@ -290,14 +290,14 @@ parsePropertyUpdate :: P.Parsec String ParseState (String, Value) parsePropertyUpdate = do - name <- C.lexeme C.identifier + name <- C.lexeme (C.identifier <|> C.stringLiteral) _ <- C.lexeme $ C.indented *> P.char '=' value <- C.indented *> parseValue return (name, value) parseAccessor :: Value -> P.Parsec String ParseState Value parseAccessor (Constructor _) = P.unexpected "constructor" -parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj +parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj parseDo :: P.Parsec String ParseState Value parseDo = do @@ -372,7 +372,7 @@ parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder) parseIdentifierAndBinder = do - name <- C.lexeme C.identifier + name <- C.lexeme (C.identifier <|> C.stringLiteral) _ <- C.lexeme $ C.indented *> P.char '=' binder <- C.indented *> parseBinder return (name, binder) diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -118,7 +118,7 @@ parsePolyType = parseAnyType parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t) -parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p +parseNameAndType p = (,) <$> (indented *> (identifier <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p parseRowEnding :: P.Parsec String ParseState Type parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier)) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -18,6 +18,7 @@ ) where import Language.PureScript.Pretty.Common +import Language.PureScript.CodeGen.JS (isIdent) import Language.PureScript.CodeGen.JS.AST import Data.List @@ -46,13 +47,17 @@ match (JSObjectLiteral ps) = fmap concat $ sequence [ return "{\n" , withIndent $ do - jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value + jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value indentString <- currentIndent return $ intercalate ", \n" $ map (indentString ++) jss , return "\n" , currentIndent , return "}" ] + where + objectPropertyToString :: String -> String + objectPropertyToString s | isIdent s = s + | otherwise = show s match (JSBlock sts) = fmap concat $ sequence [ return "{\n" , withIndent $ prettyStatements sts diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -47,6 +47,7 @@ match (ObjectLiteral ps) = fmap concat $ sequence [ return "{\n" , withIndent $ prettyPrintMany prettyPrintObjectProperty ps + , return "\n" , currentIndent , return "}" ] diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -15,8 +15,7 @@ ----------------------------------------------------------------------------- module Language.PureScript.Sugar.TypeClasses ( - desugarTypeClasses, - mkDictionaryEntryName + desugarTypeClasses ) where import Language.PureScript.Declarations @@ -30,12 +29,12 @@ import Control.Applicative import Control.Monad.State -import Control.Arrow (second) +import Control.Arrow (first, second) import Data.Maybe (catMaybes) import qualified Data.Map as M -type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)]) +type MemberMap = M.Map (ModuleName, ProperName) ([String], [(Ident, Type)]) type Desugar = StateT MemberMap (Either ErrorStack) @@ -65,10 +64,10 @@ -- class Foo a where -- foo :: a -> a -- --- instance Foo String where +-- instance fooString :: Foo String where -- foo s = s ++ s -- --- instance (Foo a) => Foo [a] where +-- instance fooArray :: (Foo a) => Foo [a] where -- foo = map foo -- -- becomes @@ -79,16 +78,11 @@ -- \ return dict.foo;\ -- \}" :: forall a. (Foo a) => a -> a -- --- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String --- --- __Test_Foo_string :: {} -> Foo String --- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) } --- --- __Test_Foo_array_foo :: forall a. (Foo a) => [a] -> [a] --- __Test_Foo_array_foo _1 = map (foo _1) +-- fooString :: {} -> Foo String +-- fooString _ = { foo: \s -> s ++ s } -- --- __Test_Foo_array :: forall a. Foo a -> Foo [a] --- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) } +-- fooArray :: forall a. (Foo a) => Foo [a] +-- fooArray = { foo: map foo } -- desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration]) desugarDecl mn d@(TypeClassDeclaration name args members) = do @@ -97,27 +91,30 @@ return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members) desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do desugared <- lift $ desugarCases members - entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared - return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl]) + return $ (Just $ TypeInstanceRef name, [d, dictDecl]) desugarDecl mn (PositionedDeclaration pos d) = do (dr, ds) <- desugarDecl mn d return (dr, map (PositionedDeclaration pos) ds) desugarDecl _ other = return (Nothing, [other]) -memberToNameAndType :: Declaration -> (String, Type) -memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty) +memberToNameAndType :: Declaration -> (Ident, Type) +memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d memberToNameAndType _ = error "Invalid declaration in type class definition" +identToProperty :: Ident -> String +identToProperty (Ident name) = name +identToProperty (Op op) = op + typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration typeClassDictionaryDeclaration name args members = - TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map memberToNameAndType members, REmpty)) + TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty)) typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = ExternDeclaration TypeClassAccessorImport ident - (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))]))) + (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))]))) (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) = PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d @@ -126,54 +123,39 @@ 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 + + -- Replace the type arguments with the appropriate types in the member types let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys - let entryName = Escaped (show name) - memberNames <- mapM (memberToNameAndValue memberTypes) decls - return $ ValueDeclaration entryName TypeInstanceDictionaryValue [] Nothing - (TypedValue True - (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)]) - (quantify (if null deps then - function unit (foldl TypeApp (TypeConstructor className) tys) - else - foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor className) tys) deps)) - ) + -- 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 dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes, REmpty)) + 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 unit :: Type unit = TypeApp tyObject REmpty - memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value) - memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do - memberType <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys' - memberName <- mkDictionaryEntryName name ident - return (identToJs ident, TypedValue False - (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps])) - (quantify memberType)) + 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 (ident, val) <- memberToNameAndValue tys' d return (ident, PositionedValue pos val) memberToNameAndValue _ _ = error "Invalid declaration in type instance definition" -typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration -typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident _ [] _ val) = do - m <- get - valTy <- lift $ do (args, members) <- lookupTypeClass m - ty' <- lookupIdent members - return $ replaceAllTypeVars (zip args tys) ty' - entryName <- mkDictionaryEntryName name ident - return $ ValueDeclaration entryName TypeInstanceMember [] Nothing - (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy))) - where - lookupTypeClass m = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $ M.lookup (qualify mn className) m - lookupIdent members = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " does not have method " ++ show ident) Nothing) Right $ lookup (identToJs ident) members -typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) = - PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d -typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition" - --- | --- Generate a name for a type class dictionary member, based on the module name, class name, type name and --- member name --- -mkDictionaryEntryName :: Ident -> Ident -> Desugar Ident -mkDictionaryEntryName dictName ident = return $ Escaped $ show dictName ++ "_" ++ identToJs ident + typeInstanceDictionaryEntryValue :: Declaration -> Value + typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val + typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d) + typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -270,7 +270,7 @@ -- A simplified representation of expressions which are used to represent type -- class dictionaries at runtime, which can be compared for equality -- -data DictionaryValue +data DictionaryValue -- | -- A dictionary which is brought into scope by a local constraint -- @@ -283,59 +283,63 @@ -- A dictionary which depends on other dictionaries -- | DependentDictionaryValue (Qualified Ident) [DictionaryValue] - deriving (Show, Eq) + 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 env moduleName context goal@(className, tys) = do - 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) +entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context)) where - go (className', tys') = - [ mkDictionary (canonicalizeDictionary tcd) args - | tcd <- nubBy ((==) `on` canonicalizeDictionary) context - -- Choose type class dictionaries in scope in the current module - , filterModule tcd - -- Make sure the type class name matches the one we are trying to satisfy - , className' == tcdClassName tcd - -- 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) ] - -- 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 - return $ Just dict - -- Make a dictionary from subgoal dictionaries by applying the correct function - mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue - mkDictionary fnName Nothing = LocalDictionaryValue fnName - mkDictionary fnName (Just []) = GlobalDictionaryValue fnName - mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts - -- Turn a DictionaryValue into a Value - dictionaryValueToValue :: DictionaryValue -> Value - dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName - dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral []) - dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts) - -- Filter out type dictionaries which are in scope in the current module - filterModule :: TypeClassDictionaryInScope -> Bool - filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True - filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True - filterModule _ = False - -- 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 + sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v] + sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs)) + + -- Filter out type dictionaries which are in scope in the current module + filterModule :: TypeClassDictionaryInScope -> Bool + filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True + 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) + where + go (className', tys') = + [ mkDictionary (canonicalizeDictionary tcd) args + | tcd <- context' + -- Make sure the type class name matches the one we are trying to satisfy + , className' == tcdClassName tcd + -- 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) ] + -- 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 + return $ Just dict + -- Make a dictionary from subgoal dictionaries by applying the correct function + mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue + mkDictionary fnName Nothing = LocalDictionaryValue fnName + mkDictionary fnName (Just []) = GlobalDictionaryValue fnName + mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts + -- Turn a DictionaryValue into a Value + dictionaryValueToValue :: DictionaryValue -> Value + dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName + dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral []) + dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts) + -- 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 -- | -- Check all values in a list pairwise match a predicate