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.
commit93ff2845ec59c84da69f41ea08395ab9b5a2f5e3 authorPhil Freeman <paf31@cantab.net> dateThu 2 Jan 2014, 20:38 (13 years ago) parentd2d684c
7 files changed+76−28
compare with golang
unifiedsplit
examples/passing/Arrays.purs+15−15 examples/passing/DataImport.purs+10 src/Language/PureScript/Declarations.hs+2−2 src/Language/PureScript/Parser/Declarations.hs+1−1 src/Language/PureScript/TypeChecker.hs+32−8 src/Language/PureScript/TypeChecker/Monad.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+15−1
examples/passing/Arrays.purs+15−15
@@ -1,22 +1,22 @@
11module Arrays where
22
3− test1 = \arr -> arr !! 0 + arr !! 1
3+test1 = \arr -> arr !! 0 + arr !! 1
44
5− test2 = \arr -> case arr of
6− [x, y] -> x + y
7− [x] -> x
8− [] -> 0
9− (x : y : _) -> x + y
5+test2 = \arr -> case arr of
6+ [x, y] -> x + y
7+ [x] -> x
8+ [] -> 0
9+ (x : y : _) -> x + y
1010
11− data Tree = One Number | Some [Tree]
11+data Tree = One Number | Some [Tree]
1212
13− test3 = \(tree, sum) -> case tree of
14− One n -> n
15− Some (n1 : n2 : rest) -> test3(n1, sum) * 10 + test3(n2, sum) * 5 + sum(rest)
13+test3 = \(tree, sum) -> case tree of
14+ One n -> n
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
1621
17− test4 = \arr -> case arr of
18− [] -> 0
19− [_] -> 0
20− x : y : xs -> x * y + test4 xs
21−
2222
examples/passing/DataImport.pursnew file+10
@@ -0,0 +1,10 @@
1+module M1 where
2+
3+data Test = Test
4+
5+module M2 where
6+
7+import M1
8+
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)
2929
3030data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
3131
32−data Module = Module ProperName [Declaration]
32+data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
3333
3434data Declaration
3535 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
@@ -41,5 +41,5 @@ data Declaration
4141 | ExternMemberDeclaration String Ident PolyType
4242 | ExternDataDeclaration ProperName Kind
4343 | FixityDeclaration Fixity String
44− | ImportDeclaration ModuleName (Maybe [Ident])
44+ | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
4545 deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Parser/Declarations.hs+1−1
@@ -90,7 +90,7 @@ parseImportDeclaration = do
9090 reserved "import"
9191 indented
9292 moduleName <- ModuleName <$> properName
93− idents <- P.optionMaybe $ parens $ commaSep1 parseIdent
93+ idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)
9494 return $ ImportDeclaration moduleName idents
9595
9696parseDeclaration :: P.Parsec String ParseState Declaration
src/Language/PureScript/TypeChecker.hs+32−8
@@ -26,15 +26,15 @@ import Language.PureScript.TypeChecker.Synonyms as T
2626
2727import Data.Maybe
2828import qualified Data.Map as M
29+import Control.Monad.State
30+import Control.Monad.Error
31+import Data.Either (rights, lefts)
2932
3033import Language.PureScript.Types
3134import Language.PureScript.Names
3235import Language.PureScript.Kinds
3336import Language.PureScript.Declarations
3437
35−import Control.Monad.State
36−import Control.Monad.Error
37−
3838typeCheckAll :: ModuleName -> [Declaration] -> Check ()
3939typeCheckAll _ [] = return ()
4040typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do
@@ -122,15 +122,39 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
122122 rethrow errorMessage $ do
123123 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
124124 case idents of
125− Nothing -> bindIdents (map snd $ filterModule env) env
126− Just idents' -> bindIdents idents' env
127− typeCheckAll moduleName rest
125+ Nothing -> do
126+ bindIdents (map snd $ filterModule (names env)) env
127+ bindTypes (map snd $ filterModule (types env)) env
128+ Just idents' -> do
129+ bindIdents (lefts idents') env
130+ bindTypes (rights idents') env
131+ typeCheckAll currentModule rest
128132 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
129− filterModule = filter ((== moduleName) . fst) . M.keys . names
130− moduleExists env = not $ null $ filterModule env
133+ filterModule = filter ((== moduleName) . fst) . M.keys
134+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
131135 bindIdents idents' env =
132136 forM_ idents' $ \ident -> do
133137 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
134138 case (moduleName, ident) `M.lookup` names env of
135139 Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
136140 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
3434
3535data NameKind = Value | Extern | Alias ModuleName Ident | LocalVariable deriving Show
3636
37−data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
37+data TypeDeclarationKind = Data | ExternData | TypeSynonym | DataAlias ModuleName ProperName deriving Show
3838
3939data Environment = Environment
4040 { 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 +
133133 ret1 `unifyTypes` ret2
134134 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
135135 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
136+ env <- getEnv
136137 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)
138139 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
139140 t3 `unifyTypes` t5
140141 t4 `unifyTypes` t6
141142 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
142143 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
143144
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+
144158typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]
145159typesOf moduleName vals = do
146160 (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do