b4d19dc · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Basic implementation of the entails relation

commitb4d19dce69a95ff6f02786e553166e4321ae14c6 authorPhil Freeman <paf31@cantab.net> dateThu 16 Jan 2014, 15:02 (13 years ago) parent0f8a6ba

6 files changed+37−15

compare with golang

unifiedsplit

examples/passing/TypeClasses.purs+1−1 src/Language/PureScript/Sugar/TypeClasses.hs+4−4 src/Language/PureScript/TypeChecker.hs+3−2 src/Language/PureScript/TypeChecker/Monad.hs+3−3 src/Language/PureScript/TypeChecker/Types.hs+25−4 src/Language/PureScript/Values.hs+1−1

examples/passing/TypeClasses.purs+1−1

@@ -8,7 +8,7 @@ instance TypeClasses.Show String where

99test1 = show "testing"

1010

11−f :: forall a. (Show a) => a -> String

11+f :: forall a. (TypeClasses.Show a) => a -> String

1212f x = show x

1313

1414test2 = f "testing"

src/Language/PureScript/Sugar/TypeClasses.hs+4−4

@@ -37,13 +37,13 @@ desugarModule :: Module -> State MemberMap Module

3737desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls

3838

3939desugarDecl :: ModuleName -> Declaration -> State MemberMap [Declaration]

40−desugarDecl mn (TypeClassDeclaration name arg members) = do

40+desugarDecl mn d@(TypeClassDeclaration name arg members) = do

4141 let tys = map memberToNameAndType members

4242 modify (M.insert (mn, name) (arg, tys))

43− return $ typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

44−desugarDecl mn (TypeInstanceDeclaration deps name ty members) = do

43+ return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

44+desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

4545 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members

46− return $ typeInstanceDictionaryDeclaration deps name ty members : entries

46+ return $ d : typeInstanceDictionaryDeclaration deps name ty members : entries

4747desugarDecl _ other = return [other]

4848

4949memberToNameAndType :: Declaration -> (String, Type)

src/Language/PureScript/TypeChecker.hs+3−2

@@ -200,8 +200,9 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

200200typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

201201 ds <- typeCheckAll moduleName rest

202202 return $ d : ds

203−typeCheckAll moduleName (d@(TypeInstanceDeclaration _ _ _ _) : rest) = do

204− ds <- typeCheckAll moduleName rest

203+typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

204+ ds <- withTypeClassDictionaries [(Ident "__TODO", deps, className, ty)] $

205+ typeCheckAll moduleName rest

205206 return $ d : ds

206207

207208qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

src/Language/PureScript/TypeChecker/Monad.hs+3−3

@@ -51,7 +51,7 @@ data Environment = Environment

5151 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

5252 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

5353 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

54− , typeClassDictionaries :: [(Ident, Qualified ProperName, Type)]

54+ , typeClassDictionaries :: [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)]

5555 } deriving (Show)

5656

5757emptyEnvironment :: Environment

@@ -73,7 +73,7 @@ bindTypes newNames action = do

7373 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

7474 return a

7575

76−withTypeClassDictionaries :: (MonadState CheckState m) => [(Ident, Qualified ProperName, Type)] -> m a -> m a

76+withTypeClassDictionaries :: (MonadState CheckState m) => [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)] -> m a -> m a

7777withTypeClassDictionaries entries action = do

7878 orig <- get

7979 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

@@ -81,7 +81,7 @@ withTypeClassDictionaries entries action = do

8181 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

8282 return a

8383

84−getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [(Ident, Qualified ProperName, Type)]

84+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)]

8585getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

8686

8787bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

src/Language/PureScript/TypeChecker/Types.hs+25−4

@@ -20,7 +20,7 @@ module Language.PureScript.TypeChecker.Types (

2020) where

2121

2222import Data.List

23−import Data.Maybe (isNothing, isJust, fromMaybe)

23+import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)

2424import qualified Data.Data as D

2525import Data.Generics

2626 (mkM, everywhereM, everything, mkT, something, everywhere, mkQ)

@@ -188,8 +188,29 @@ replaceTypeClassDictionaries = everywhereM (mkM go)

188188 go (TypeClassDictionary constraint dicts) = entails dicts constraint

189189 go other = return other

190190

191−entails :: [(Ident, Qualified ProperName, Type)] -> (Qualified ProperName, Type) -> Check Value

192−entails _ _ = return $ Var $ Qualified Nothing $ Ident "placeholder" -- TODO

191+entails :: [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)] -> (Qualified ProperName, Type) -> Check Value

192+entails context goal =

193+ case go goal of

194+ [] -> throwError $ "No type class instance for " ++ show goal ++ " in context " ++ show context

195+ (dict : _) -> return dict

196+ where

197+ go (className, ty) = [ App (Var (Qualified Nothing fnName)) args

198+ | (fnName, subgoals, className', ty') <- context

199+ , className == className'

200+ , subst <- maybeToList $ typeHeadsAreEqual ty ty'

201+ , args <- forM (replaceAllTypeVars subst subgoals) go ]

202+ typeHeadsAreEqual :: Type -> Type -> Maybe [(String, Type)]

203+ typeHeadsAreEqual String String = Just []

204+ typeHeadsAreEqual Number Number = Just []

205+ typeHeadsAreEqual Boolean Boolean = Just []

206+ typeHeadsAreEqual (Skolem s1) (Skolem s2) | s1 == s2 = Just []

207+ typeHeadsAreEqual (Array ty1) (Array ty2) = typeHeadsAreEqual ty1 ty2

208+ typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

209+ typeHeadsAreEqual (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = do

210+ m <- typeHeadsAreEqual h1 h2

211+ return $ (v, arg) : m

212+ typeHeadsAreEqual t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual t2 t1

213+ typeHeadsAreEqual _ _ = Nothing

193214

194215escapeCheck :: Value -> Type -> Subst ()

195216escapeCheck value ty = do

@@ -612,7 +633,7 @@ check' val (ForAll idents ty) = do

612633 check val sk

613634check' val (ConstrainedType constraints ty) = do

614635 let dictName = Ident "__dict" -- TODO

615− val' <- withTypeClassDictionaries (map (\(className, instanceTy) -> (dictName, className, instanceTy)) constraints) $ check val ty

636+ val' <- withTypeClassDictionaries (map (\(className, instanceTy) -> (dictName, [], className, instanceTy)) constraints) $ check val ty

616637 return $ Abs (map (\_ -> dictName) constraints) val'

617638check' val u@(TUnknown _) = do

618639 val'@(TypedValue _ ty) <- infer val

src/Language/PureScript/Values.hs+1−1

@@ -73,7 +73,7 @@ data Value

7373 | Case [Value] [([Binder], Maybe Guard, Value)]

7474 | TypedValue Value Type

7575 | Do Value [DoNotationElement]

76− | TypeClassDictionary (Qualified ProperName, Type) [(Ident, Qualified ProperName, Type)] deriving (Show, Data, Typeable)

76+ | TypeClassDictionary (Qualified ProperName, Type) [(Ident, [(Qualified ProperName, Type)], Qualified ProperName, Type)] deriving (Show, Data, Typeable)

7777

7878data DoNotationElement

7979 = DoNotationValue Value