summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-10 21:06:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-10 21:06:00 (GMT)
commit0e6a7ff9ce3358d2b6170d37b0930e7097ba399d (patch)
tree224c6cb8307483009aeb99523627eac26fbb8dc9
parentf14e0a7e3a2b5efc455480c1d110fddc648214a5 (diff)
version 0.2.100.2.10
-rw-r--r--purescript.cabal29
-rw-r--r--src/Language/PureScript.hs15
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs32
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs3
-rw-r--r--src/Language/PureScript/Declarations.hs3
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs6
-rw-r--r--src/Language/PureScript/Pretty/JS.hs1
-rw-r--r--src/Language/PureScript/Sugar.hs32
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs (renamed from src/Language/PureScript/BindingGroups.hs)2
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs (renamed from src/Language/PureScript/CaseDeclarations.hs)2
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs (renamed from src/Language/PureScript/DoNotation.hs)4
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs (renamed from src/Language/PureScript/Operators.hs)4
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs (renamed from src/Language/PureScript/TypeDeclarations.hs)4
-rw-r--r--src/Language/PureScript/TypeChecker.hs27
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs5
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs8
17 files changed, 88 insertions, 91 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 4769c67..fc8ee4c 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.9.2
+version: 0.2.10
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -18,18 +18,27 @@ library
directory -any, filepath -any, mtl -any, parsec -any, syb -any,
transformers -any, utf8-string -any
exposed-modules: Data.Generics.Extras
- Language.PureScript.Options
Language.PureScript
+ Language.PureScript.Options
+ Language.PureScript.Declarations
+ Language.PureScript.Kinds
+ Language.PureScript.Names
+ Language.PureScript.Types
+ Language.PureScript.Unknown
+ Language.PureScript.Values
+ Language.PureScript.Scope
+ Language.PureScript.Sugar
+ Language.PureScript.Sugar.CaseDeclarations
+ Language.PureScript.Sugar.DoNotation
+ Language.PureScript.Sugar.TypeDeclarations
+ Language.PureScript.Sugar.BindingGroups
+ Language.PureScript.Sugar.Operators
Language.PureScript.CodeGen
Language.PureScript.CodeGen.Externs
Language.PureScript.CodeGen.JS
Language.PureScript.CodeGen.JS.AST
Language.PureScript.CodeGen.Monad
Language.PureScript.CodeGen.Optimize
- Language.PureScript.Declarations
- Language.PureScript.Kinds
- Language.PureScript.Names
- Language.PureScript.Operators
Language.PureScript.Parser
Language.PureScript.Parser.Common
Language.PureScript.Parser.Declarations
@@ -48,14 +57,6 @@ library
Language.PureScript.TypeChecker.Monad
Language.PureScript.TypeChecker.Synonyms
Language.PureScript.TypeChecker.Types
- Language.PureScript.Types
- Language.PureScript.Unknown
- Language.PureScript.Values
- Language.PureScript.CaseDeclarations
- Language.PureScript.DoNotation
- Language.PureScript.TypeDeclarations
- Language.PureScript.BindingGroups
- Language.PureScript.Scope
exposed: True
buildable: True
hs-source-dirs: src
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 0c64fbb..07716ee 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -23,24 +23,15 @@ import Language.PureScript.Parser as P
import Language.PureScript.CodeGen as P
import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
-import Language.PureScript.Operators as P
-import Language.PureScript.CaseDeclarations as P
-import Language.PureScript.TypeDeclarations as P
-import Language.PureScript.BindingGroups as P
-import Language.PureScript.DoNotation as P
+import Language.PureScript.Sugar as P
import Language.PureScript.Options as P
import Data.List (intercalate)
-import Control.Monad (forM_, (>=>))
+import Control.Monad (forM_)
compile :: Options -> [Module] -> Either String (String, String, Environment)
compile opts ms = do
- bracketted <- rebracket ms
- desugared <- desugarDo
- >=> desugarCasesModule
- >=> desugarTypeDeclarationsModule
- >=> (return . createBindingGroupsModule)
- $ bracketted
+ desugared <- desugar ms
(_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls
let js = prettyPrintJS . map (optimize opts) . concatMap (flip (moduleToJs opts) env) $ desugared
let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 8e04d05..7fce595 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -40,8 +40,6 @@ declToPs path env (BindingGroupDeclaration vals) = do
declToPs path env (DataDeclaration name _ _) = maybeToList $ do
(kind, _) <- M.lookup (path, name) $ types env
return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
-declToPs _ _ (ExternMemberDeclaration member name ty) =
- return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty
declToPs _ _ (ExternDataDeclaration name kind) =
return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
declToPs _ _ (TypeSynonymDeclaration name args ty) =
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index af95cc1..a057899 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -23,7 +23,7 @@ import qualified Data.Map as M
import Control.Arrow (second)
import Control.Monad (replicateM, forM)
-import Language.PureScript.TypeChecker (Environment, names)
+import Language.PureScript.TypeChecker (Environment(..), NameKind(..))
import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Scope
@@ -32,17 +32,23 @@ import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.Monad
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
-import Language.PureScript.TypeChecker.Monad (NameKind(..))
import Language.PureScript.Types
moduleToJs :: Options -> Module -> Environment -> [JS]
moduleToJs opts (Module pname@(ProperName name) decls) env =
+ let
+ rawDecls = mapMaybe filterRawDecls decls
+ in
+ map JSRaw rawDecls ++
[ JSVariableIntroduction (Ident name) Nothing
, JSApp (JSFunction Nothing [Ident name]
(JSBlock (concat $ mapMaybe (\decl -> declToJs opts (ModuleName pname) decl env) decls)))
[JSAssignment (JSAssignVariable (Ident name))
(JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
]
+ where
+ filterRawDecls (ExternDeclaration _ (Just js) _) = Just js
+ filterRawDecls _ = Nothing
declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
declToJs opts mp (ValueDeclaration ident _ _ val) e =
@@ -53,24 +59,6 @@ declToJs opts mp (BindingGroupDeclaration vals) e =
[ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
setProperty (identToJs ident) (JSVar ident) mp ]
) vals
-declToJs _ mp (ExternMemberDeclaration member ident ty) _
- | returnsFunction ty =
- Just [ JSFunction (Just ident) [Ident "value"] (JSBlock
- [ JSReturn $ JSApp (JSAccessor "bind" (JSAccessor member (JSVar (Ident "value")))) [JSVar (Ident "value")]
- ]),
- setProperty (show ident) (JSVar ident) mp ]
- | otherwise =
- Just [ JSFunction (Just ident) [Ident "value"] (JSBlock
- [ JSReturn $ JSAccessor member (JSVar (Ident "value"))
- ]),
- setProperty (show ident) (JSVar ident) mp ]
- where
- returnsFunction (Function _ ret) = isFunction ret
- returnsFunction (ForAll _ ty') = returnsFunction ty'
- returnsFunction _ = error "Expected function type in declToJs"
- isFunction (Function _ _) = True
- isFunction (ForAll _ ty') = isFunction ty'
- isFunction _ = False
declToJs _ mp (DataDeclaration _ _ ctors) _ =
Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
let
@@ -94,6 +82,10 @@ valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]
+valueToJs _ m e (Constructor (Qualified Nothing name)) =
+ case M.lookup (m, name) (dataConstructors e) of
+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
+ _ -> JSVar . Ident . runProperName $ name
valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name
valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []
valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 0a239d5..7d531cf 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -46,7 +46,8 @@ data JS
| JSTypeOf JS
| JSLabel String JS
| JSBreak String
- | JSContinue String deriving (Show, Data, Typeable)
+ | JSContinue String
+ | JSRaw String deriving (Show, Data, Typeable)
data JSAssignment
= JSAssignVariable Ident
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 34bb8c5..8b4c98e 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -38,8 +38,7 @@ data Declaration
| TypeDeclaration Ident Type
| ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
| BindingGroupDeclaration [(Ident, Value)]
- | ExternDeclaration Ident Type
- | ExternMemberDeclaration String Ident Type
+ | ExternDeclaration Ident (Maybe String) Type
| ExternDataDeclaration ProperName Kind
| FixityDeclaration Fixity String
| ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index b1d5d77..3e16282 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -65,10 +65,8 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "im
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
<*> (lexeme (indented *> P.string "::") *> parseKind)
<|> ExternDeclaration <$> parseIdent
- <*> (lexeme (indented *> P.string "::") *> parsePolyType)
- <|> ExternMemberDeclaration <$> (P.try (reserved "member") *> indented *> stringLiteral)
- <*> (indented *> parseIdent)
- <*> (lexeme (indented *> P.string "::") *> parsePolyType))
+ <*> P.optionMaybe stringLiteral
+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))
parseAssociativity :: P.Parsec String ParseState Associativity
parseAssociativity =
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 7a3c933..6ff4ede 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -124,6 +124,7 @@ literals = mkPattern' match
[ return $ lbl ++ ": "
, prettyPrintJS' js
]
+ match (JSRaw js) = return js
match _ = mzero
targetToJs :: JSAssignment -> String
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
new file mode 100644
index 0000000..3d224ba
--- /dev/null
+++ b/src/Language/PureScript/Sugar.hs
@@ -0,0 +1,32 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Sugar
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Sugar (desugar, module S) where
+
+import Control.Monad
+
+import Language.PureScript.Declarations
+
+import Language.PureScript.Sugar.Operators as S
+import Language.PureScript.Sugar.DoNotation as S
+import Language.PureScript.Sugar.CaseDeclarations as S
+import Language.PureScript.Sugar.TypeDeclarations as S
+import Language.PureScript.Sugar.BindingGroups as S
+
+desugar :: [Module] -> Either String [Module]
+desugar = rebracket
+ >=> desugarDo
+ >=> desugarCasesModule
+ >=> desugarTypeDeclarationsModule
+ >=> return . createBindingGroupsModule
diff --git a/src/Language/PureScript/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 9740936..0262eba 100644
--- a/src/Language/PureScript/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.BindingGroups (
+module Language.PureScript.Sugar.BindingGroups (
createBindingGroups,
createBindingGroupsModule
) where
diff --git a/src/Language/PureScript/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 66c9ea7..6b1ea46 100644
--- a/src/Language/PureScript/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.CaseDeclarations (
+module Language.PureScript.Sugar.CaseDeclarations (
desugarCases,
desugarCasesModule
) where
diff --git a/src/Language/PureScript/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 52d897f..3d8c71f 100644
--- a/src/Language/PureScript/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.DoNotation
+-- Module : Language.PureScript.Sugar.DoNotation
-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.DoNotation (
+module Language.PureScript.Sugar.DoNotation (
desugarDo
) where
diff --git a/src/Language/PureScript/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index c942f9d..56c9ca0 100644
--- a/src/Language/PureScript/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Operators
+-- Module : Language.PureScript.Sugar.Operators
-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
@@ -14,7 +14,7 @@
{-# LANGUAGE Rank2Types #-}
-module Language.PureScript.Operators (
+module Language.PureScript.Sugar.Operators (
rebracket
) where
diff --git a/src/Language/PureScript/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 4c84088..bc8ef23 100644
--- a/src/Language/PureScript/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -1,6 +1,6 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.TypeDeclarations
+-- Module : Language.PureScript.Sugar.TypeDeclarations
-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-module Language.PureScript.TypeDeclarations (
+module Language.PureScript.Sugar.TypeDeclarations (
desugarTypeDeclarations,
desugarTypeDeclarationsModule
) where
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 01526bd..8c979c7 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -50,7 +50,7 @@ addDataConstructor moduleName name args dctor maybeTy = do
let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
let polyType = mkForAll args dctorTy
- putEnv $ env { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env) }
+ putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (polyType, DataConstructor) (dataConstructors env) }
addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
addTypeSynonym moduleName name args ty kind = do
@@ -125,24 +125,7 @@ typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do
guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
typeCheckAll moduleName rest
-typeCheckAll moduleName (ExternMemberDeclaration member name ty : rest) = do
- rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do
- env <- getEnv
- kind <- kindOf moduleName ty
- guardWith "Expected kind *" $ kind == Star
- case M.lookup (moduleName, name) (names env) of
- Just _ -> throwError $ show name ++ " is already defined"
- Nothing -> case ty of
- _ | isSingleArgumentFunction ty -> do
- putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env)
- , members = M.insert (moduleName, name) member (members env) })
- | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."
- typeCheckAll moduleName rest
- where
- isSingleArgumentFunction (Function [_] _) = True
- isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t
- isSingleArgumentFunction _ = False
-typeCheckAll moduleName (ExternDeclaration name ty : rest) = do
+typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do
rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
env <- getEnv
kind <- kindOf moduleName ty
@@ -183,16 +166,16 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
Just (k, _) -> do
modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
- let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env
+ let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
forM_ keys $ \dctor -> do
guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
case (moduleName, dctor) `M.lookup` dataConstructors env of
- Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })
+ Just (ctorTy, _) -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
constructs (TypeConstructor (Qualified (Just mn) pn')) pn
= mn == moduleName && pn' == pn
constructs (ForAll _ ty) pn = ty `constructs` pn
constructs (Function _ ty) pn = ty `constructs` pn
constructs (TypeApp ty _) pn = ty `constructs` pn
- constructs fn _ = error $ "Invalid arguments to construct" ++ show fn
+ constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 700754a..140d7d8 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -36,7 +36,8 @@ data NameKind
= Value
| Extern
| Alias ModuleName Ident
- | LocalVariable deriving Show
+ | LocalVariable
+ | DataConstructor deriving Show
data TypeDeclarationKind
= Data
@@ -48,7 +49,7 @@ data TypeDeclarationKind
data Environment = Environment
{ names :: M.Map (ModuleName, Ident) (Type, NameKind)
, types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
- , dataConstructors :: M.Map (ModuleName, ProperName) Type
+ , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
, typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
, members :: M.Map (ModuleName, Ident) String
} deriving (Show)
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 8701f2c..b5bc04f 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -337,7 +337,7 @@ infer' (Constructor c) = do
moduleName <- substCurrentModule `fmap` ask
case M.lookup (qualify moduleName c) (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just ty -> replaceAllTypeSynonyms ty
+ Just (ty, _) -> replaceAllTypeSynonyms ty
infer' (Case vals binders) = do
ts <- mapM infer vals
ret <- fresh
@@ -450,7 +450,7 @@ inferBinder val (NullaryBinder ctor) = do
env <- getEnv
moduleName <- substCurrentModule <$> ask
case M.lookup (qualify moduleName ctor) (dataConstructors env) of
- Just ty -> do
+ Just (ty, _) -> do
ty `subsumes` val
return M.empty
_ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
@@ -458,7 +458,7 @@ inferBinder val (UnaryBinder ctor binder) = do
env <- getEnv
moduleName <- substCurrentModule <$> ask
case M.lookup (qualify moduleName ctor) (dataConstructors env) of
- Just ty -> do
+ Just (ty, _) -> do
fn <- replaceAllVarsWithUnknowns ty
case fn of
Function [obj] ret -> do
@@ -649,7 +649,7 @@ check' (Constructor c) ty = do
moduleName <- substCurrentModule <$> ask
case M.lookup (qualify moduleName c) (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just ty1 -> do
+ Just (ty1, _) -> do
repl <- replaceAllTypeSynonyms ty1
repl `subsumes` ty
check' val (SaturatedTypeSynonym name args) = do