5c9e25e · rowtype-yoga/purescript-native

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

Introduce saturated type synonyms to allow type synonyms to persist until unification

commit5c9e25e28281487289c48794db840e8a3835d746 authorPhil Freeman <paf31@cantab.net> dateTue 29 Oct 2013, 18:03 (13 years ago) parent38d43e4

4 files changed+48−25

compare with golang

unifiedsplit

src/PureScript/CodeGen/Pretty/Types.hs+1 src/PureScript/TypeChecker/Synonyms.hs+17−17 src/PureScript/TypeChecker/Types.hs+28−7 src/PureScript/Types.hs+2−1

src/PureScript/CodeGen/Pretty/Types.hs+1

@@ -43,6 +43,7 @@ typeLiterals = Pattern $ A.Kleisli match

4343 match (TypeVar var) = Just var

4444 match (TypeConstructor ctor) = Just ctor

4545 match (TUnknown u) = Just $ "u" ++ show u

46+ match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

4647 match _ = Nothing

4748

4849prettyPrintRow :: Row -> String

src/PureScript/TypeChecker/Synonyms.hs+17−17

@@ -15,7 +15,8 @@

1515{-# LANGUAGE Rank2Types #-}

1616

1717module PureScript.TypeChecker.Synonyms (

18− substituteTypeSynonym

18+ saturateTypeSynonym,

19+ saturateAllTypeSynonyms

1920) where

2021

2122import PureScript.Types

@@ -29,20 +30,13 @@ import Control.Monad.Writer

2930import Control.Monad.Error

3031import qualified Data.Map as M

3132

32−replaceTypeVars :: M.Map String Type -> Type -> Type

33−replaceTypeVars m = everywhere (mkT replace)

33+buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type)

34+buildTypeSubstitution name n = go n []

3435 where

35− replace :: Type -> Type

36− replace t@(TypeVar var) = fromMaybe t (M.lookup var m)

37− replace t = t

38−

39−buildTypeSubstitution :: String -> Type -> [String] -> Type -> Either String (Maybe Type)

40−buildTypeSubstitution name ty args = go (reverse args) M.empty

41− where

42− go :: [String] -> M.Map String Type -> Type -> Either String (Maybe Type)

43− go [] m (TypeConstructor ctor) | name == ctor = return (Just $ replaceTypeVars m ty)

44− go (_:_) _ (TypeConstructor ctor) | name == ctor = throwError $ "Partially applied type synonym " ++ name

45− go (arg:args) m (TypeApp f x) = go args (M.insert arg x m) f

36+ go :: Int -> [Type] -> Type -> Either String (Maybe Type)

37+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

38+ go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ name

39+ go n args (TypeApp f arg) = go (n - 1) (arg:args) f

4640 go _ _ _ = return Nothing

4741

4842everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d

@@ -50,7 +44,13 @@ everywhereM' f x = do

5044 y <- f x

5145 gmapM (everywhereM' f) y

5246

53−substituteTypeSynonym :: (Data d) => String -> [String] -> Type -> d -> Either String d

54−substituteTypeSynonym name args ty = everywhereM' (mkM replace)

47+saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d

48+saturateTypeSynonym name n = everywhereM' (mkM replace)

5549 where

56− replace t = fmap (fromMaybe t) $ buildTypeSubstitution name ty args t

50+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t

51+

52+saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d

53+saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns

54+

55+

56+

src/PureScript/TypeChecker/Types.hs+28−7

@@ -65,7 +65,7 @@ typeOf name val = do

6565 solution <- solveTypeConstraints desugared emptyTypeSolution

6666 let ty = fst (runTypeSolution solution) n

6767 allUnknownsBecameQuantified desugared solution ty

68− return $ varIfUnknown ty

68+ return $ varIfUnknown $ desaturateAllTypeSynonyms ty

6969

7070allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()

7171allUnknownsBecameQuantified cs solution ty = do

@@ -133,6 +133,14 @@ varIfUnknown ty =

133133 Just name -> return $ RowVar name

134134 g r = return r

135135

136+replaceTypeVars :: M.Map String Type -> Type -> Type

137+replaceTypeVars m = everywhere (mkT replace)

138+ where

139+ replace (TypeVar v) = case M.lookup v m of

140+ Just ty -> ty

141+ _ -> TypeVar v

142+ replace t = t

143+

136144replaceVarsWithUnknowns :: [String] -> Type -> Check Type

137145replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)

138146 where

@@ -158,14 +166,16 @@ replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip ext

158166 g r = return r

159167

160168replaceAllTypeSynonyms :: (D.Data d) => d -> Check d

161−replaceAllTypeSynonyms ty = do

169+replaceAllTypeSynonyms d = do

162170 env <- getEnv

163− go (M.toList $ typeSynonyms env) ty

171+ let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

172+ either throwError return $ saturateAllTypeSynonyms syns d

173+

174+desaturateAllTypeSynonyms :: (D.Data d) => d -> d

175+desaturateAllTypeSynonyms = everywhere (mkT $ replace)

164176 where

165− go [] d = return d

166− go ((name, (args, repl)):rest) d = do

167− d' <- either throwError return (substituteTypeSynonym name args repl d)

168− go rest d'

177+ replace (SaturatedTypeSynonym name args) = foldl (\t arg -> TypeApp t arg) (TypeConstructor name) args

178+ replace t = t

169179

170180replaceType :: (D.Data d) => Int -> Type -> d -> d

171181replaceType n t = everywhere (mkT go)

@@ -521,6 +531,17 @@ unifyTypes (TUnknown u) t = do

521531unifyTypes t (TUnknown u) = do

522532 typeOccursCheck u t

523533 return [TypeConstraint u t]

534+unifyTypes (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =

535+ fmap concat $ zipWithM unifyTypes args1 args2

536+unifyTypes (SaturatedTypeSynonym name args) ty = do

537+ env <- getEnv

538+ case M.lookup name (typeSynonyms env) of

539+ Just (synArgs, body) -> do

540+ let m = M.fromList $ zip synArgs args

541+ let replaced = replaceTypeVars m body

542+ unifyTypes replaced ty

543+ Nothing -> error "Type synonym was not defined"

544+unifyTypes ty s@(SaturatedTypeSynonym _ _) = unifyTypes s ty

524545unifyTypes Number Number = return []

525546unifyTypes String String = return []

526547unifyTypes Boolean Boolean = return []

src/PureScript/Types.hs+2−1

@@ -28,7 +28,8 @@ data Type

2828 | Function [Type] Type

2929 | TypeVar String

3030 | TypeConstructor String

31− | TypeApp Type Type deriving (Show, Eq, Data, Typeable)

31+ | TypeApp Type Type

32+ | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable)

3233

3334data PolyType = PolyType [String] Type deriving (Show, Data, Typeable)

3435