packages feed

purescript 0.4.15.1 → 0.4.16

raw patch · 13 files changed

+130/−147 lines, 13 files

Files

prelude/prelude.purs view
@@ -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 <<<
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.4.15.1+version: 0.4.16 cabal-version: >=1.8 build-type: Custom license: MIT
src/Language/PureScript/CodeGen/Common.hs view
@@ -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)
src/Language/PureScript/CodeGen/JS.hs view
@@ -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]
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -19,8 +19,6 @@  import Data.Data -- -- | -- Built-in unary operators --
src/Language/PureScript/Environment.hs view
@@ -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
src/Language/PureScript/Names.hs view
@@ -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.
src/Language/PureScript/Parser/Declarations.hs view
@@ -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)
src/Language/PureScript/Parser/Types.hs view
@@ -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))
src/Language/PureScript/Pretty/JS.hs view
@@ -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
src/Language/PureScript/Pretty/Values.hs view
@@ -47,6 +47,7 @@   match (ObjectLiteral ps) = fmap concat $ sequence     [ return "{\n"     , withIndent $ prettyPrintMany prettyPrintObjectProperty ps+    , return "\n"     , currentIndent     , return "}"     ]
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -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"
src/Language/PureScript/TypeChecker/Types.hs view
@@ -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