93ff284 · rowtype-yoga/purescript-native

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

on golang help sign in

Import data types using import keyword, fix prelude, fix some errors when unifying types across modules.

93ff284Phil Freeman13 years ago

examples/passing/Arrays.purs+15−15

compare with golang

unifiedsplit

@@ -1,22 +1,22 @@

1module Arrays where

3− test1 = \arr -> arr !! 0 + arr !! 1

3+test1 = \arr -> arr !! 0 + arr !! 1

5− test2 = \arr -> case arr of

5+test2 = \arr -> case arr of

6− [x, y] -> x + y

6+ [x, y] -> x + y

7− [x] -> x

7+ [x] -> x

8− [] -> 0

8+ [] -> 0

9− (x : y : _) -> x + y

9+ (x : y : _) -> x + y

11− data Tree = One Number | Some [Tree]

11+data Tree = One Number | Some [Tree]

13− test3 = \(tree, sum) -> case tree of

13+test3 = \(tree, sum) -> case tree of

14− One n -> n

14+ One n -> n

15− Some (n1 : n2 : rest) -> test3(n1, sum) * 10 + test3(n2, sum) * 5 + sum(rest)

15+ Some (n1 : n2 : rest) -> test3(n1, sum) * 10 + test3(n2, sum) * 5 + sum(rest)

16+

17+test4 = \arr -> case arr of

18+ [] -> 0

19+ [_] -> 0

20+ x : y : xs -> x * y + test4 xs

17− test4 = \arr -> case arr of

18− [] -> 0

19− [_] -> 0

20− x : y : xs -> x * y + test4 xs

21−

examples/passing/DataImport.pursnew file+10

@@ -0,0 +1,10 @@

1+module M1 where

3+data Test = Test

5+module M2 where

7+import M1

9+test :: Test -> M1.Test

10+test t = t

src/Language/PureScript/Declarations.hs+2−2

@@ -29,7 +29,7 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

30data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

32−data Module = Module ProperName [Declaration]

32+data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)

34data Declaration

35 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]

@@ -41,5 +41,5 @@ data Declaration

41 | ExternMemberDeclaration String Ident PolyType

42 | ExternDataDeclaration ProperName Kind

43 | FixityDeclaration Fixity String

44− | ImportDeclaration ModuleName (Maybe [Ident])

44+ | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])

45 deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/Parser/Declarations.hs+1−1

@@ -90,7 +90,7 @@ parseImportDeclaration = do

90 reserved "import"

91 indented

92 moduleName <- ModuleName <$> properName

93− idents <- P.optionMaybe $ parens $ commaSep1 parseIdent

93+ idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

94 return $ ImportDeclaration moduleName idents

96parseDeclaration :: P.Parsec String ParseState Declaration

src/Language/PureScript/TypeChecker.hs+32−8

@@ -26,15 +26,15 @@ import Language.PureScript.TypeChecker.Synonyms as T

27import Data.Maybe

28import qualified Data.Map as M

29+import Control.Monad.State

30+import Control.Monad.Error

31+import Data.Either (rights, lefts)

30import Language.PureScript.Types

33import Language.PureScript.Types

31import Language.PureScript.Names

34import Language.PureScript.Names

32import Language.PureScript.Kinds

35import Language.PureScript.Kinds

33import Language.PureScript.Declarations

36import Language.PureScript.Declarations

35−import Control.Monad.State

36−import Control.Monad.Error

37−

38typeCheckAll :: ModuleName -> [Declaration] -> Check ()

39typeCheckAll _ [] = return ()

40typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do

@@ -122,15 +122,39 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

122 rethrow errorMessage $ do

123 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

124 case idents of

125+ Nothing -> do

125− Nothing -> bindIdents (map snd $ filterModule env) env

126+ bindIdents (map snd $ filterModule (names env)) env

127+ bindTypes (map snd $ filterModule (types env)) env

128+ Just idents' -> do

126− Just idents' -> bindIdents idents' env

129+ bindIdents (lefts idents') env

130+ bindTypes (rights idents') env

127− typeCheckAll moduleName rest

131+ typeCheckAll currentModule rest

128 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

132 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

129− filterModule = filter ((== moduleName) . fst) . M.keys . names

133+ filterModule = filter ((== moduleName) . fst) . M.keys

130− moduleExists env = not $ null $ filterModule env

134+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))

131 bindIdents idents' env =

135 bindIdents idents' env =

132 forM_ idents' $ \ident -> do

136 forM_ idents' $ \ident -> do

133 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

137 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

134 case (moduleName, ident) `M.lookup` names env of

138 case (moduleName, ident) `M.lookup` names env of

135 Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

139 Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

136 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

140 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

141+ bindTypes pns env =

142+ forM_ pns $ \pn -> do

143+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env

144+ case (moduleName, pn) `M.lookup` types env of

145+ Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

146+ Just (k, _) -> do

147+ modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })

148+ let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env

149+ forM_ keys $ \dctor -> do

150+ guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env

151+ case (moduleName, dctor) `M.lookup` dataConstructors env of

152+ Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })

153+ Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")

154+ constructs (TypeConstructor (Qualified (Just mn) pn')) pn

155+ = mn == moduleName && pn' == pn

156+ constructs (ForAll _ ty) pn = ty `constructs` pn

157+ constructs (Function _ ty) pn = ty `constructs` pn

158+ constructs (TypeApp ty _) pn = ty `constructs` pn

159+ constructs fn _ = error $ "Invalid arguments to construct" ++ show fn

160+

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

@@ -34,7 +34,7 @@ import qualified Data.Map as M

35data NameKind = Value | Extern | Alias ModuleName Ident | LocalVariable deriving Show

37−data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

37+data TypeDeclarationKind = Data | ExternData | TypeSynonym | DataAlias ModuleName ProperName deriving Show

39data Environment = Environment

40 { names :: M.Map (ModuleName, Ident) (Type, NameKind)

src/Language/PureScript/TypeChecker/Types.hs+15−1

@@ -133,14 +133,28 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

133 ret1 `unifyTypes` ret2

134 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

135 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

136+ env <- getEnv

136 moduleName <- substCurrentModule `fmap` ask

137 moduleName <- substCurrentModule `fmap` ask

137− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify moduleName c1 == qualify moduleName c2)

138+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)

138 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

139 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

139 t3 `unifyTypes` t5

140 t3 `unifyTypes` t5

140 t4 `unifyTypes` t6

141 t4 `unifyTypes` t6

141 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()

142 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()

142 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

143 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

143

144

145+typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

146+typeConstructorsAreEqual env moduleName c1 c2 =

147+ let

148+ c1' = qualify moduleName c1

149+ c2' = qualify moduleName c2

150+ in

151+ canonicalize env c1' == canonicalize env c2'

152+ where

153+ canonicalize :: Environment -> (ModuleName, ProperName) -> (ModuleName, ProperName)

154+ canonicalize _ key = case key `M.lookup` types env of

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

156+ _ -> key

157+

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

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

145typesOf moduleName vals = do

159typesOf moduleName vals = do

146 (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do

160 (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do