git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix type synonyms issue
commit45b60f3fbfd4ab176a9cf5574652e6da6ffb439a authorPhil Freeman <paf31@cantab.net> dateSat 11 Jan 2014, 10:43 (13 years ago) parent0289bb6
4 files changed+29−25
compare with golang
unifiedsplit
libraries/prelude/prelude.purs+2−2 src/Language/PureScript/TypeChecker/Monad.hs+12 src/Language/PureScript/TypeChecker/Synonyms.hs+10−9 src/Language/PureScript/TypeChecker/Types.hs+5−14
libraries/prelude/prelude.purs+2−2
@@ -22,7 +22,7 @@ module Prelude where
2222 ($) :: forall a b. (a -> b) -> a -> b
2323 ($) f x = f x
2424
25− infixr 1000 $
25+ infixl 1000 $
2626
2727module Maybe where
2828
@@ -275,7 +275,7 @@ module Eff where
275275
276276 type Pure a = forall e. Eff e a
277277
278− foreign import runPure :: forall a. Pure a -> a
278+ foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a
279279
280280 eff = { ret: retEff, bind: bindEff }
281281
src/Language/PureScript/TypeChecker/Monad.hs+12
@@ -95,6 +95,18 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
9595 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
9696 Just (k, _) -> return k
9797
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+
98110data AnyUnifiable where
99111 AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable
100112
src/Language/PureScript/TypeChecker/Synonyms.hs+10−9
@@ -19,6 +19,7 @@ module Language.PureScript.TypeChecker.Synonyms (
1919
2020import Language.PureScript.Types
2121import Language.PureScript.Names
22+import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType)
2223
2324import Data.Maybe (fromMaybe)
2425import Data.Data
@@ -27,22 +28,22 @@ import Data.Generics.Extras
2728import Control.Monad.Writer
2829import Control.Monad.Error
2930
30−buildTypeSubstitution :: ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
31−buildTypeSubstitution moduleName name n = go n []
31+buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)
32+buildTypeSubstitution env moduleName name n = go n []
3233 where
3334 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 m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
35+ go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)
36+ go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name
3637 go m args (TypeApp f arg) = go (m - 1) (arg:args) f
3738 go _ _ _ = return Nothing
3839
39−saturateTypeSynonym :: (Data d) => ModuleName -> Qualified ProperName -> Int -> d -> Either String d
40−saturateTypeSynonym moduleName name n = everywhereM' (mkM replace)
40+saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d
41+saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
4142 where
42− replace t = fmap (fromMaybe t) $ buildTypeSubstitution moduleName name n t
43+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
4344
44−saturateAllTypeSynonyms :: (Data d) => ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d
45−saturateAllTypeSynonyms moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym moduleName name n result) d syns
45+saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d
46+saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
4647
4748
4849
src/Language/PureScript/TypeChecker/Types.hs+5−14
@@ -44,6 +44,7 @@ import Control.Applicative
4444import Control.Arrow (Arrow(..))
4545
4646import qualified Data.Map as M
47+import Data.Function (on)
4748
4849instance Unifiable Type where
4950 unknown = TUnknown
@@ -139,17 +140,7 @@ unifyRows r1 r2 =
139140 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
140141
141142typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
142−typeConstructorsAreEqual env moduleName c1 c2 =
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
143+typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
153144
154145typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]
155146typesOf moduleName vals = do
@@ -240,8 +231,8 @@ replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader Subst
240231replaceAllTypeSynonyms d = do
241232 env <- getEnv
242233 moduleName <- substCurrentModule <$> ask
243− let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env
244− either throwError return $ saturateAllTypeSynonyms moduleName syns d
234+ let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
235+ either throwError return $ saturateAllTypeSynonyms env moduleName syns d
245236
246237desaturateAllTypeSynonyms :: (D.Data d) => d -> d
247238desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
@@ -253,7 +244,7 @@ expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
253244expandTypeSynonym name args = do
254245 env <- getEnv
255246 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
257248 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
258249 Nothing -> error "Type synonym was not defined"
259250