45b60f3 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix type synonyms issue

45b60f3Phil Freeman13 years ago

libraries/prelude/prelude.purs+2−2

compare with golang

unifiedsplit

@@ -22,7 +22,7 @@ module Prelude where

22 ($) :: forall a b. (a -> b) -> a -> b

23 ($) f x = f x

25− infixr 1000 $

25+ infixl 1000 $

27module Maybe where

@@ -275,7 +275,7 @@ module Eff where

275

276 type Pure a = forall e. Eff e a

277

278− foreign import runPure :: forall a. Pure a -> a

278+ foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a

279

280 eff = { ret: retEff, bind: bindEff }

281

src/Language/PureScript/TypeChecker/Monad.hs+12

@@ -95,6 +95,18 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

95 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

96 Just (k, _) -> return k

98+canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)

99+canonicalize _ _ (Qualified (Just mn) i) = (mn, i)

100+canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of

101+ Just (_, Alias mn' i') -> (mn', i')

102+ _ -> (mn, i)

103+

104+canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

105+canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)

106+canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of

107+ Just (_, DataAlias mn' pn') -> (mn', pn')

108+ _ -> (mn, nm)

109+

98data AnyUnifiable where

110data AnyUnifiable where

99 AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable

111 AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable

100

112

src/Language/PureScript/TypeChecker/Synonyms.hs+10−9

@@ -19,6 +19,7 @@ module Language.PureScript.TypeChecker.Synonyms (

20import Language.PureScript.Types

21import Language.PureScript.Names

22+import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType)

23import Data.Maybe (fromMaybe)

24import Data.Maybe (fromMaybe)

24import Data.Data

25import Data.Data

@@ -27,22 +28,22 @@ import Data.Generics.Extras

27import Control.Monad.Writer

28import Control.Monad.Writer

28import Control.Monad.Error

29import Control.Monad.Error

30−buildTypeSubstitution :: ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)

31+buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)

31−buildTypeSubstitution moduleName name n = go n []

32+buildTypeSubstitution env moduleName name n = go n []

32 where

33 where

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

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

34− go 0 args (TypeConstructor ctor) | qualify moduleName name == qualify moduleName ctor = return (Just $ SaturatedTypeSynonym ctor args)

35+ go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)

35− go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name

36+ go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name

36 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

37 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

37 go _ _ _ = return Nothing

38 go _ _ _ = return Nothing

39−saturateTypeSynonym :: (Data d) => ModuleName -> Qualified ProperName -> Int -> d -> Either String d

40+saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d

40−saturateTypeSynonym moduleName name n = everywhereM' (mkM replace)

41+saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)

41 where

42 where

42− replace t = fmap (fromMaybe t) $ buildTypeSubstitution moduleName name n t

43+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t

44−saturateAllTypeSynonyms :: (Data d) => ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d

45+saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d

45−saturateAllTypeSynonyms moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym moduleName name n result) d syns

46+saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns

src/Language/PureScript/TypeChecker/Types.hs+5−14

@@ -44,6 +44,7 @@ import Control.Applicative

44import Control.Arrow (Arrow(..))

46import qualified Data.Map as M

47+import Data.Function (on)

48instance Unifiable Type where

49instance Unifiable Type where

49 unknown = TUnknown

50 unknown = TUnknown

@@ -139,17 +140,7 @@ unifyRows r1 r2 =

139 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."

140 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."

140

141

141typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

142typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

142−typeConstructorsAreEqual env moduleName c1 c2 =

143+typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env

143− let

144− c1' = qualify moduleName c1

145− c2' = qualify moduleName c2

146− in

147− canonicalize env c1' == canonicalize env c2'

148− where

149− canonicalize :: Environment -> (ModuleName, ProperName) -> (ModuleName, ProperName)

150− canonicalize _ key = case key `M.lookup` types env of

151− Just (_, DataAlias mn' pn') -> (mn', pn')

152− _ -> key

153

144

154typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]

145typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]

155typesOf moduleName vals = do

146typesOf moduleName vals = do

@@ -240,8 +231,8 @@ replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader Subst

240replaceAllTypeSynonyms d = do

231replaceAllTypeSynonyms d = do

241 env <- getEnv

232 env <- getEnv

242 moduleName <- substCurrentModule <$> ask

233 moduleName <- substCurrentModule <$> ask

243− let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env

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

244− either throwError return $ saturateAllTypeSynonyms moduleName syns d

235+ either throwError return $ saturateAllTypeSynonyms env moduleName syns d

245

236

246desaturateAllTypeSynonyms :: (D.Data d) => d -> d

237desaturateAllTypeSynonyms :: (D.Data d) => d -> d

247desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

238desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

@@ -253,7 +244,7 @@ expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type

253expandTypeSynonym name args = do

244expandTypeSynonym name args = do

254 env <- getEnv

245 env <- getEnv

255 moduleName <- substCurrentModule `fmap` ask

246 moduleName <- substCurrentModule `fmap` ask

256− case M.lookup (qualify moduleName name) (typeSynonyms env) of

247+ case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of

257 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body

248 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body

258 Nothing -> error "Type synonym was not defined"

249 Nothing -> error "Type synonym was not defined"

259

250