summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-24 18:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-24 18:41:00 (GMT)
commit420422183cd0b2518d111705486d389ccb9e1cba (patch)
treebc3674521412a37f7072126b72c22709514808d8
parenta86a55fd578bfc2046da533294d23be1973b5c23 (diff)
version 0.3.20.3.2
-rw-r--r--purescript.cabal23
-rw-r--r--src/Language/PureScript.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs38
-rw-r--r--src/Language/PureScript/Declarations.hs32
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs61
-rw-r--r--src/Language/PureScript/Sugar.hs2
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs76
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs3
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs24
-rw-r--r--src/Language/PureScript/TypeChecker.hs17
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs31
11 files changed, 228 insertions, 85 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 8dd28d3..db00cd1 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.1
+version: 0.3.2
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -11,8 +11,8 @@ synopsis: PureScript Programming Language Compiler
description: A small compile-to-JS language with extensible records and type-safe blocks
category: Language
author: Phil Freeman <paf31@cantab.net>
-data-dir: ""
data-files: libraries/prelude/prelude.purs
+data-dir: ""
library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
@@ -29,6 +29,7 @@ library
Language.PureScript.Values
Language.PureScript.Scope
Language.PureScript.Sugar
+ Language.PureScript.ModuleDependencies
Language.PureScript.Sugar.CaseDeclarations
Language.PureScript.Sugar.DoNotation
Language.PureScript.Sugar.TypeDeclarations
@@ -63,32 +64,32 @@ library
exposed: True
buildable: True
hs-source-dirs: src
+ other-modules:
executable psc
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
directory -any, filepath -any, mtl -any, parsec -any,
purescript -any, syb -any, transformers -any, utf8-string -any
main-is: Main.hs
- hs-source-dirs: psc
buildable: True
+ hs-source-dirs: psc
other-modules:
ghc-options: -Wall -O2 -fno-warn-unused-do-bind
executable psci
- build-depends: base >=4 && <5, containers -any,
- mtl -any, parsec -any, haskeline <= 0.7.1.1,
- purescript -any, syb -any, transformers -any, utf8-string -any,
- process -any
+ build-depends: base >=4 && <5, containers -any, mtl -any,
+ parsec -any, haskeline <=0.7.1.1, purescript -any, syb -any,
+ transformers -any, utf8-string -any, process -any
main-is: Main.hs
- hs-source-dirs: psci
buildable: True
+ hs-source-dirs: psci
other-modules:
ghc-options: -Wall -O2
test-suite tests
- build-depends: base >=4 && <5, containers -any,
- directory -any, filepath -any, mtl -any, parsec -any,
- purescript -any, syb -any, transformers -any, utf8-string -any
+ build-depends: base >=4 && <5, containers -any, directory -any,
+ filepath -any, mtl -any, parsec -any, purescript -any, syb -any,
+ transformers -any, utf8-string -any
type: exitcode-stdio-1.0
main-is: Main.hs
buildable: True
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index a308678..45c9d75 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -25,6 +25,7 @@ import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
import Language.PureScript.Sugar as P
import Language.PureScript.Options as P
+import Language.PureScript.ModuleDependencies as P
import Data.List (intercalate)
import Control.Monad (when, forM)
@@ -33,9 +34,10 @@ import qualified Data.Map as M
compile :: Options -> [Module] -> Either String (String, String, Environment)
compile opts ms = do
- desugared <- desugar ms
+ sorted <- sortModules ms
+ desugared <- desugar sorted
(elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls
- let regrouped = createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
+ regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
let js = concatMap (flip (moduleToJs opts) env) $ regrouped
let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped
js' <- case () of
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 7f5dc69..e4b9836 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -12,14 +12,17 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE DoAndIfThenElse #-}
+
module Language.PureScript.CodeGen.JS (
module AST,
declToJs,
moduleToJs
) where
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (sortBy)
+import Data.Function (on)
import Control.Arrow (second)
import Control.Monad (replicateM, forM)
@@ -143,7 +146,9 @@ varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of
Just (_, ty) | isExtern ty -> JSVar ident
Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
- _ -> qualifiedToJS identToJs qual
+ _ -> case qual of
+ Qualified Nothing _ -> JSVar ident
+ _ -> qualifiedToJS identToJs qual
where
isExtern (Extern ForeignImport) = True
isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
@@ -182,12 +187,23 @@ binderToJs _ _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs _ _ varName done (VarBinder ident) =
return (JSVariableIntroduction ident (Just (JSVar varName)) : done)
-binderToJs m _ varName done (NullaryBinder ctor) =
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
+binderToJs m e varName done (NullaryBinder ctor) =
+ if isOnlyConstructor m e ctor
+ then
+ return done
+ else
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
binderToJs m e varName done (UnaryBinder ctor b) = do
value <- fresh
js <- binderToJs m e value done b
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)) Nothing]
+ let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)
+ if isOnlyConstructor m e ctor
+ then
+ return [success]
+ else
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor))))
+ success
+ Nothing]
binderToJs m e varName done (ObjectBinder bs) = go done bs
where
go :: [JS] -> [(String, Binder)] -> Gen [JS]
@@ -222,6 +238,18 @@ binderToJs m e varName done (NamedBinder ident binder) = do
js <- binderToJs m e varName done binder
return (JSVariableIntroduction ident (Just (JSVar varName)) : js)
+isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool
+isOnlyConstructor m e ctor =
+ let (ty, _) = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e
+ in numConstructors ty == 1
+ where
+ numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
+ typeConstructor (TypeConstructor qual) = qualify m qual
+ typeConstructor (ForAll _ ty) = typeConstructor ty
+ typeConstructor (Function _ ty) = typeConstructor ty
+ typeConstructor (TypeApp ty _) = typeConstructor ty
+ typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
+
statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 1495f8f..71c543e 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -39,7 +39,7 @@ data ForeignImportType
data Declaration
= DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
- | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]
+ | DataBindingGroupDeclaration [Declaration]
| TypeSynonymDeclaration ProperName [String] Type
| TypeDeclaration Ident Type
| ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
@@ -51,3 +51,33 @@ data Declaration
| TypeClassDeclaration ProperName String [Declaration]
| TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]
deriving (Show, D.Data, D.Typeable)
+
+isValueDecl :: Declaration -> Bool
+isValueDecl (ValueDeclaration _ _ _ _) = True
+isValueDecl _ = False
+
+isDataDecl :: Declaration -> Bool
+isDataDecl (DataDeclaration _ _ _) = True
+isDataDecl (TypeSynonymDeclaration _ _ _) = True
+isDataDecl _ = False
+
+isImportDecl :: Declaration -> Bool
+isImportDecl (ImportDeclaration _ _) = True
+isImportDecl _ = False
+
+isExternDataDecl :: Declaration -> Bool
+isExternDataDecl (ExternDataDeclaration _ _) = True
+isExternDataDecl _ = False
+
+isFixityDecl :: Declaration -> Bool
+isFixityDecl (FixityDeclaration _ _) = True
+isFixityDecl _ = False
+
+isExternDecl :: Declaration -> Bool
+isExternDecl (ExternDeclaration _ _ _ _) = True
+isExternDecl _ = False
+
+isTypeClassDeclaration :: Declaration -> Bool
+isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True
+isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True
+isTypeClassDeclaration _ = False
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
new file mode 100644
index 0000000..ecf917b
--- /dev/null
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -0,0 +1,61 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.ModuleDependencies
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.ModuleDependencies (
+ sortModules
+) where
+
+import Data.Data
+import Data.Graph
+import Data.Generics
+import Data.List (nub, intersect)
+import Control.Applicative ((<$>))
+
+import Language.PureScript.Declarations
+import Language.PureScript.Names
+import Language.PureScript.Values
+import Language.PureScript.Types
+
+sortModules :: [Module] -> Either String [Module]
+sortModules ms = do
+ let verts = map (\m -> (m, getModuleName m, usedModules m)) ms
+ mapM toModule $ stronglyConnComp verts
+
+collapseBindingGroups :: [Declaration] -> [Declaration]
+collapseBindingGroups ds = concatMap go ds
+ where
+ go (DataBindingGroupDeclaration ds) = ds
+ go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
+ go other = [other]
+
+usedModules :: (Data d) => d -> [ProperName]
+usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)
+ where
+ qualifiedIdents :: Qualified Ident -> [ProperName]
+ qualifiedIdents (Qualified (Just (ModuleName pn)) _) = [pn]
+ qualifiedIdents _ = []
+ qualifiedProperNames :: Qualified ProperName -> [ProperName]
+ qualifiedProperNames (Qualified (Just (ModuleName pn)) _) = [pn]
+ qualifiedProperNames _ = []
+ imports :: Declaration -> [ProperName]
+ imports (ImportDeclaration (ModuleName pn) _) = [pn]
+ imports _ = []
+
+getModuleName :: Module -> ProperName
+getModuleName (Module pn _) = pn
+
+toModule :: SCC Module -> Either String Module
+toModule (AcyclicSCC m) = return m
+toModule (CyclicSCC [m]) = return m
+toModule (CyclicSCC _) = Left "Cycle in module dependencies"
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index fd26f2b..92f1b81 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -31,4 +31,4 @@ desugar = desugarTypeClasses
>=> desugarDo
>=> desugarCasesModule
>=> desugarTypeDeclarationsModule
- >=> return . createBindingGroupsModule
+ >=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index cbbc547..006bcfd 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -23,49 +23,50 @@ import Data.Data
import Data.Graph
import Data.Generics
import Data.List (nub, intersect)
+import Control.Applicative ((<$>))
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Types
-createBindingGroupsModule :: [Module] -> [Module]
-createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
+createBindingGroupsModule :: [Module] -> Either String [Module]
+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups ds
collapseBindingGroupsModule :: [Module] -> [Module]
collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)
-createBindingGroups :: [Declaration] -> [Declaration]
-createBindingGroups ds =
- let
- values = filter isValueDecl ds
- dataDecls = filter isDataDecl ds
- nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds
- allProperNames = map getProperName dataDecls
- dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
- dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts
- allIdents = map getIdent values
- valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
- bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
- in
- dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls
+createBindingGroups :: [Declaration] -> Either String [Declaration]
+createBindingGroups ds = do
+ let values = filter isValueDecl ds
+ dataDecls = filter isDataDecl ds
+ allProperNames = map getProperName dataDecls
+ dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
+ dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
+ let allIdents = map getIdent values
+ valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
+ return $ filter isImportDecl ds ++
+ filter isExternDataDecl ds ++
+ dataBindingGroupDecls ++
+ filter isTypeClassDeclaration ds ++
+ filter isFixityDecl ds ++
+ filter isExternDecl ds ++
+ bindingGroupDecls
collapseBindingGroups :: [Declaration] -> [Declaration]
collapseBindingGroups ds = concatMap go ds
where
- go (DataBindingGroupDeclaration ds) = map (\(name, args, dctors) -> DataDeclaration name args dctors) ds
+ go (DataBindingGroupDeclaration ds) = ds
go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
go other = [other]
usedIdents :: (Data d) => d -> [Ident]
-usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)
+usedIdents = nub . everything (++) (mkQ [] names)
where
- namesV :: Value -> [Ident]
- namesV (Var (Qualified Nothing name)) = [name]
- namesV _ = []
- namesS :: Statement -> [Ident]
- namesS (VariableIntroduction name _) = [name]
- namesS _ = []
+ names :: Value -> [Ident]
+ names (Var (Qualified Nothing name)) = [name]
+ names _ = []
usedProperNames :: (Data d) => d -> [ProperName]
usedProperNames = nub . everything (++) (mkQ [] names)
@@ -74,20 +75,13 @@ usedProperNames = nub . everything (++) (mkQ [] names)
names (TypeConstructor (Qualified Nothing name)) = [name]
names _ = []
-isValueDecl :: Declaration -> Bool
-isValueDecl (ValueDeclaration _ _ _ _) = True
-isValueDecl _ = False
-
-isDataDecl :: Declaration -> Bool
-isDataDecl (DataDeclaration _ _ _) = True
-isDataDecl _ = False
-
getIdent :: Declaration -> Ident
getIdent (ValueDeclaration ident _ _ _) = ident
getIdent _ = error "Expected ValueDeclaration"
getProperName :: Declaration -> ProperName
getProperName (DataDeclaration pn _ _) = pn
+getProperName (TypeSynonymDeclaration pn _ _) = pn
getProperName _ = error "Expected DataDeclaration"
toBindingGroup :: SCC Declaration -> Declaration
@@ -95,16 +89,18 @@ toBindingGroup (AcyclicSCC d) = d
toBindingGroup (CyclicSCC [d]) = d
toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
-toDataBindingGroup :: SCC Declaration -> Declaration
-toDataBindingGroup (AcyclicSCC d) = d
-toDataBindingGroup (CyclicSCC [d]) = d
-toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'
+toDataBindingGroup :: SCC Declaration -> Either String Declaration
+toDataBindingGroup (AcyclicSCC d) = return d
+toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn
+toDataBindingGroup (CyclicSCC [d]) = return d
+toDataBindingGroup (CyclicSCC ds')
+ | all isTypeSynonym ds' = Left "Cycle in type synonyms"
+ | otherwise = return $ DataBindingGroupDeclaration ds'
+ where
+ isTypeSynonym (TypeSynonymDeclaration _ _ _) = True
+ isTypeSynonym _ = False
fromValueDecl :: Declaration -> (Ident, Value)
fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
fromValueDecl _ = error "Expected ValueDeclaration"
-
-fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe Type)])
-fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)
-fromDataDecl _ = error "Expected DataDeclaration"
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 0eae3a2..22cde6e 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -96,9 +96,6 @@ collectFixities m moduleName (FixityDeclaration fixity name : rest) = do
collectFixities (M.insert qual fixity m) moduleName rest
collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do
let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]
- forM_ fs $ \(name, _) -> do
- let qual = Qualified (Just moduleName) name
- when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)
collectFixities (M.union m' m) moduleName rest
collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 90ac4a8..951ed0c 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -73,22 +73,29 @@ typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type c
typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
typeInstanceDictionaryDeclaration mn deps name ty decls = do
+ m <- get
+ (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
+ $ M.lookup (qualify mn name) m
+ let memberTypes = map (replaceTypeVars arg ty) instanceTys
entryName <- lift $ mkDictionaryValueName mn name ty
- memberNames <- mapM memberToNameAndValue decls
+ memberNames <- mapM (memberToNameAndValue memberTypes) decls
return $ ValueDeclaration entryName [] Nothing
- (TypedValue False
+ (TypedValue True
(Abs
(map (\n -> Ident ('_' : show n)) [1..length deps])
(ObjectLiteral memberNames))
(quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))
)
where
- memberToNameAndValue :: Declaration -> Desugar (String, Value)
- memberToNameAndValue (ValueDeclaration ident _ _ _) = do
+ memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
+ memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do
+ memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys
memberName <- mkDictionaryEntryName mn name ty ident
- return (identToJs ident, if null deps then Var (Qualified Nothing memberName)
- else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
- memberToNameAndValue _ = error "Invalid declaration in type instance definition"
+ return (identToJs ident, TypedValue False
+ (if null deps then Var (Qualified Nothing memberName)
+ else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
+ (quantify memberType))
+ memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do
@@ -123,9 +130,10 @@ typeToString _ String = return "string"
typeToString _ Number = return "number"
typeToString _ Boolean = return "boolean"
typeToString _ Array = return "array"
+typeToString _ (TypeVar _) = return "var"
typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'
-typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"
+typeToString a b = Left $ "Type class instance must be of the form T a1 ... an " ++ show (a, b)
mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
mkDictionaryEntryName mn name ty ident = do
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 0e4409b..8146fc5 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -98,14 +98,23 @@ typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
ds <- typeCheckAll moduleName rest
return $ d : ds
typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
- rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do
- forM_ tys $ \(name, _, _) ->
+ rethrow ("Error in data binding group:\n" ++) $ do
+ let syns = mapMaybe toTypeSynonym tys
+ let dataDecls = mapMaybe toDataDecl tys
+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) dataDecls)
+ forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do
typeIsNotDefined moduleName name
- ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)
- forM_ (zip tys ks) $ \((name, args, dctors), ctorKind) ->
addDataType moduleName name args dctors ctorKind
+ forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
+ typeIsNotDefined moduleName name
+ addTypeSynonym moduleName name args ty kind
ds <- typeCheckAll moduleName rest
return $ d : ds
+ where
+ toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
+ toTypeSynonym _ = Nothing
+ toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
+ toDataDecl _ = Nothing
typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
typeIsNotDefined moduleName name
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5b492f7..5263a7f 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -68,16 +68,27 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k))
bindLocalTypeVariables moduleName dict $
solveTypes ts kargs tyCon
-kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]
-kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, s) -> apply s ks)) . runSubst (SubstContext moduleName) $ do
- tyCons <- replicateM (length tys) fresh
- let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
- bindLocalTypeVariables moduleName dict $
- zipWithM (\tyCon (_, args, ts) -> do
- kargs <- replicateM (length args) fresh
- let argDict = zip (map ProperName args) kargs
- bindLocalTypeVariables moduleName argDict $
- solveTypes ts kargs tyCon) tyCons tys
+kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])
+kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do
+ synVars <- replicateM (length syns) fresh
+ let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
+ bindLocalTypeVariables moduleName dict $ do
+ tyCons <- replicateM (length tys) fresh
+ let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
+ bindLocalTypeVariables moduleName dict $ do
+ data_ks <- zipWithM (\tyCon (_, args, ts) -> do
+ kargs <- replicateM (length args) fresh
+ let argDict = zip (map ProperName args) kargs
+ bindLocalTypeVariables moduleName argDict $
+ solveTypes ts kargs tyCon) tyCons tys
+ syn_ks <- zipWithM (\synVar (_, args, ty) -> do
+ kargs <- replicateM (length args) fresh
+ let argDict = zip (map ProperName args) kargs
+ bindLocalTypeVariables moduleName argDict $
+ solveTypes [ty] kargs synVar) synVars syns
+ return (syn_ks, data_ks)
+ where
+ tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2)
solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind
solveTypes ts kargs tyCon = do