5c9e25e · rowtype-yoga/purescript-native

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

on golang help sign in

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

5c9e25ePhil Freeman13 years ago

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

compare with golang

unifiedsplit

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

43 match (TypeVar var) = Just var

44 match (TypeConstructor ctor) = Just ctor

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

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

46 match _ = Nothing

47 match _ = Nothing

48prettyPrintRow :: Row -> String

49prettyPrintRow :: Row -> String

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

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

15{-# LANGUAGE Rank2Types #-}

17module PureScript.TypeChecker.Synonyms (

18− substituteTypeSynonym

18+ saturateTypeSynonym,

19+ saturateAllTypeSynonyms

19) where

20) where

21import PureScript.Types

22import PureScript.Types

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

29import Control.Monad.Error

30import Control.Monad.Error

30import qualified Data.Map as M

31import qualified Data.Map as M

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

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

33−replaceTypeVars m = everywhere (mkT replace)

34+buildTypeSubstitution name n = go n []

34 where

35 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)

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

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

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

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

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

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

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

46 go _ _ _ = return Nothing

40 go _ _ _ = return Nothing

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

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

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

50 y <- f x

44 y <- f x

51 gmapM (everywhereM' f) y

45 gmapM (everywhereM' f) y

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

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

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

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

55 where

49 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

65 solution <- solveTypeConstraints desugared emptyTypeSolution

66 let ty = fst (runTypeSolution solution) n

67 allUnknownsBecameQuantified desugared solution ty

68− return $ varIfUnknown ty

68+ return $ varIfUnknown $ desaturateAllTypeSynonyms ty

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

71allUnknownsBecameQuantified cs solution ty = do

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

133 Just name -> return $ RowVar name

134 g r = return r

135

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+

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

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

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

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

138 where

146 where

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

158 g r = return r

166 g r = return r

159

167

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

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

161−replaceAllTypeSynonyms ty = do

169+replaceAllTypeSynonyms d = do

162 env <- getEnv

170 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)

164 where

176 where

165− go [] d = return d

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

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

178+ replace t = t

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

168− go rest d'

169

179

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

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

171replaceType n t = everywhere (mkT go)

181replaceType n t = everywhere (mkT go)

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

521unifyTypes t (TUnknown u) = do

531unifyTypes t (TUnknown u) = do

522 typeOccursCheck u t

532 typeOccursCheck u t

523 return [TypeConstraint u t]

533 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

524unifyTypes Number Number = return []

545unifyTypes Number Number = return []

525unifyTypes String String = return []

546unifyTypes String String = return []

526unifyTypes Boolean Boolean = return []

547unifyTypes Boolean Boolean = return []

src/PureScript/Types.hs+2−1

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

28 | Function [Type] Type

29 | TypeVar String

30 | TypeConstructor String

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

31+ | TypeApp Type Type

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

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

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