summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-05 00:34:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-05 00:34:00 (GMT)
commit18bfb3763659066d5977d8bb19921b4607571b1e (patch)
tree5ea18f411e3b68e2e29b139159575ebddc0739e3
parent4f0ee1881db1a659a4030d6a35487bd9c6d01379 (diff)
version 0.4.30.4.3
-rw-r--r--docgen/Main.hs6
-rw-r--r--prelude/prelude.purs159
-rw-r--r--psci/Main.hs29
-rw-r--r--purescript.cabal3
-rw-r--r--src/Data/Generics/Extras.hs31
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs28
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs86
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs13
-rw-r--r--src/Language/PureScript/Declarations.hs22
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs30
-rw-r--r--src/Language/PureScript/Parser/Values.hs10
-rw-r--r--src/Language/PureScript/Pretty/Values.hs5
-rw-r--r--src/Language/PureScript/Sugar.hs10
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs8
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs16
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs4
-rw-r--r--src/Language/PureScript/Sugar/Let.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs303
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs68
-rw-r--r--src/Language/PureScript/TypeChecker.hs107
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs96
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs15
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs51
-rw-r--r--src/Language/PureScript/Values.hs52
-rw-r--r--tests/Main.hs17
27 files changed, 699 insertions, 480 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index bf817b5..ca4fbbb 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -102,11 +102,11 @@ renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do
renderDeclaration n (P.TypeClassDeclaration name args ds) = do
atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"
mapM_ (renderDeclaration (n + 2)) ds
-renderDeclaration n (P.TypeInstanceDeclaration constraints name tys _) = do
+renderDeclaration n (P.TypeInstanceDeclaration name constraints className tys _) = do
let constraintsText = case constraints of
[] -> ""
cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "
- atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)
+ atIndent n $ constraintsText ++ "instance " ++ show name ++ " :: " ++ show className ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)
renderDeclaration _ _ = return ()
getName :: P.Declaration -> String
@@ -116,7 +116,7 @@ getName (P.DataDeclaration name _ _) = P.runProperName name
getName (P.ExternDataDeclaration name _) = P.runProperName name
getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
getName (P.TypeClassDeclaration name _ _) = P.runProperName name
-getName (P.TypeInstanceDeclaration _ name _ _) = show name
+getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
getName _ = error "Invalid argument to getName"
isValueDeclaration :: P.Declaration -> Bool
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index fea92d2..5e966d5 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -14,7 +14,7 @@ module Prelude where
(<<<) :: forall b c d. a c d -> a b c -> a b d
(>>>) :: forall b c d. a b c -> a c d -> a b d
- instance Category (->) where
+ instance categoryArr :: Category (->) where
id x = x
(<<<) f g x = f (g x)
(>>>) f g x = g (f x)
@@ -31,36 +31,36 @@ module Prelude where
class Show a where
show :: a -> String
- instance Show String where
+ instance showString :: Show String where
show s = s
- instance Show Boolean where
+ instance showBoolean :: Show Boolean where
show true = "true"
show false = "false"
- foreign import showNumber "function showNumber(n) {\
- \ return n.toString();\
- \}" :: Number -> String
+ foreign import showNumberImpl "function showNumberImpl(n) {\
+ \ return n.toString();\
+ \}" :: Number -> String
- instance Prelude.Show Number where
- show = showNumber
+ instance showNumber :: Show Number where
+ show = showNumberImpl
class Read a where
read :: String -> a
- instance Read String where
+ instance readString :: Read String where
read s = s
- instance Read Boolean where
+ instance readBoolean :: Read Boolean where
read "true" = true
read _ = false
- foreign import readNumber "function readNumber(n) {\
- \ return parseFloat(n);\
- \}" :: String -> Number
+ foreign import readNumberImpl "function readNumber(n) {\
+ \ return parseFloat(n);\
+ \}" :: String -> Number
- instance Read Number where
- read = readNumber
+ instance readNumber :: Read Number where
+ read = readNumberImpl
infixl 4 <$>
@@ -73,7 +73,7 @@ module Prelude where
pure :: forall a. a -> f a
(<*>) :: forall a b. f (a -> b) -> f a -> f b
- instance (Applicative f) => Functor f where
+ instance functorFromApplicative :: (Applicative f) => Functor f where
(<$>) f a = pure f <*> a
infixl 3 <|>
@@ -88,7 +88,7 @@ module Prelude where
return :: forall a. a -> m a
(>>=) :: forall a b. m a -> (a -> m b) -> m b
- instance (Monad m) => Applicative m where
+ instance applicativeFromMonad :: (Monad m) => Applicative m where
pure = return
(<*>) f a = do
f' <- f
@@ -144,7 +144,7 @@ module Prelude where
\ return -n;\
\}" :: Number -> Number
- instance Num Number where
+ instance numNumber :: Num Number where
(+) = numAdd
(-) = numSub
(*) = numMul
@@ -159,18 +159,6 @@ module Prelude where
(==) :: a -> a -> Boolean
(/=) :: a -> a -> Boolean
- -- Referential equality
- data Ref a = Ref a
-
- liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
- liftRef f (Ref x) (Ref y) = f x y
-
- refEq :: forall a. Ref a -> Ref a -> Boolean
- refEq = liftRef unsafeRefEq
-
- refIneq :: forall a. Ref a -> Ref a -> Boolean
- refIneq = liftRef unsafeRefIneq
-
foreign import unsafeRefEq "function unsafeRefEq(r1) {\
\ return function(r2) {\
\ return r1 === r2;\
@@ -183,23 +171,19 @@ module Prelude where
\ };\
\}" :: forall a. a -> a -> Boolean
- instance Eq (Ref a) where
- (==) = refEq
- (/=) = refIneq
-
- instance Eq String where
+ instance eqString :: Eq String where
(==) = unsafeRefEq
(/=) = unsafeRefIneq
- instance Eq Number where
+ instance eqNumber :: Eq Number where
(==) = unsafeRefEq
(/=) = unsafeRefIneq
- instance Eq Boolean where
+ instance eqBoolean :: Eq Boolean where
(==) = unsafeRefEq
(/=) = unsafeRefIneq
- instance (Eq a) => Eq [a] where
+ instance eqArray :: (Eq a) => Eq [a] where
(==) [] [] = true
(==) (x:xs) (y:ys) = x == y && xs == ys
(==) _ _ = false
@@ -240,7 +224,7 @@ module Prelude where
\ };\
\}" :: Number -> Number -> Boolean
- instance Ord Number where
+ instance ordNumber :: Ord Number where
(<) = numLess
(>) = numGreater
(<=) = numLessEq
@@ -299,7 +283,7 @@ module Prelude where
\ return ~n;\
\}" :: Number -> Number
- instance Bits Number where
+ instance bitsNumber :: Bits Number where
(&) = numAnd
(|) = numOr
(^) = numXor
@@ -340,7 +324,7 @@ module Prelude where
\ return !b;\
\}" :: Boolean -> Boolean
- instance BoolLike Boolean where
+ instance boolLikeBoolean :: BoolLike Boolean where
(&&) = boolAnd
(||) = boolOr
not = boolNot
@@ -364,11 +348,11 @@ module Data.Monoid where
mempty :: m
(<>) :: m -> m -> m
- instance Monoid String where
+ instance monoidString :: Monoid String where
mempty = ""
(<>) = (++)
- instance Monoid [a] where
+ instance monoidArray :: Monoid [a] where
mempty = []
(<>) = Data.Array.concat
@@ -425,6 +409,9 @@ module Control.Monad where
when true m = m
when false _ = return {}
+ zipWithM :: forall m a b c. (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+ zipWithM f xs ys = sequence $ zipWith f xs ys
+
module Data.Maybe where
import Prelude
@@ -436,22 +423,22 @@ module Data.Maybe where
maybe _ f (Just a) = f a
fromMaybe :: forall a. a -> Maybe a -> a
- fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
+ fromMaybe a = maybe a (id :: forall a. a -> a)
- instance Prelude.Monad Maybe where
+ instance monadMaybe :: Monad Maybe where
return = Just
(>>=) m f = maybe Nothing f m
- instance Prelude.Applicative Maybe where
+ instance applicativeMaybe :: Applicative Maybe where
pure = Just
(<*>) (Just fn) x = fn <$> x
(<*>) Nothing _ = Nothing
- instance Prelude.Functor Maybe where
+ instance functorMaybe :: Functor Maybe where
(<$>) fn (Just x) = Just (fn x)
(<$>) _ _ = Nothing
- instance (Show a) => Prelude.Show (Maybe a) where
+ instance showMaybe :: (Show a) => Show (Maybe a) where
show (Just x) = "Just " ++ (show x)
show Nothing = "Nothing"
@@ -465,20 +452,20 @@ module Data.Either where
either f _ (Left a) = f a
either _ g (Right b) = g b
- instance Prelude.Monad (Either e) where
+ instance monadEither :: Monad (Either e) where
return = Right
(>>=) = either (\e _ -> Left e) (\a f -> f a)
- instance Prelude.Applicative (Either e) where
+ instance applicativeEither :: Applicative (Either e) where
pure = Right
(<*>) (Left e) _ = Left e
(<*>) (Right f) r = f <$> r
- instance Prelude.Functor (Either a) where
+ instance functorEither :: Functor (Either a) where
(<$>) _ (Left x) = Left x
(<$>) f (Right y) = Right (f y)
- instance (Show a, Show b) => Prelude.Show (Either a b) where
+ instance showEither :: (Show a, Show b) => Show (Either a b) where
show (Left x) = "Left " ++ (show x)
show (Right y) = "Right " ++ (show y)
@@ -573,7 +560,7 @@ module Data.Array where
\ return l1;\
\}" :: forall a. [a] -> [a]
- foreign import insertAt
+ foreign import insertAt
"function insertAt(index) {\
\ return function(a) {\
\ return function(l) {\
@@ -584,7 +571,7 @@ module Data.Array where
\ };\
\}":: forall a. Number -> a -> [a] -> [a]
- foreign import deleteAt
+ foreign import deleteAt
"function deleteAt(index) {\
\ return function(n) {\
\ return function(l) {\
@@ -595,7 +582,7 @@ module Data.Array where
\ };\
\}":: forall a. Number -> Number -> [a] -> [a]
- foreign import updateAt
+ foreign import updateAt
"function updateAt(index) {\
\ return function(a) {\
\ return function(l) {\
@@ -622,7 +609,7 @@ module Data.Array where
filter _ [] = []
filter p (x:xs) | p x = x : filter p xs
filter p (_:xs) = filter p xs
-
+
find :: forall a. (a -> Boolean) -> [a] -> Maybe a
find _ [] = Nothing
find p (x:xs) | p x = Just x
@@ -648,20 +635,50 @@ module Data.Array where
all _ [] = true
all p (a:as) = p a && all p as
- instance (Prelude.Show a) => Prelude.Show [a] where
- show xs = "[" ++ joinWith (map show xs) "," ++ "]"
+ drop :: forall a. Number -> [a] -> [a]
+ drop 0 xs = xs
+ drop _ [] = []
+ drop n (x:xs) = drop (n - 1) xs
- instance Prelude.Functor [] where
- (<$>) = map
+ take :: forall a. Number -> [a] -> [a]
+ take 0 _ = []
+ take _ [] = []
+ take n (x:xs) = x : take (n - 1) xs
- instance Prelude.Monad [] where
+ instance showArray :: (Show a) => Show [a] where
+ show xs = "[" ++ joinWith (map show xs) "," ++ "]"
+
+ instance monadArray :: Monad [] where
return = singleton
(>>=) = concatMap
- instance Prelude.Alternative [] where
+ instance functorArray :: Functor [] where
+ (<$>) = map
+
+ instance alternativeArray :: Alternative [] where
empty = []
(<|>) = concat
-
+
+module Data.Eq where
+
+ import Prelude
+
+ -- Referential equality
+ data Ref a = Ref a
+
+ liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
+ liftRef f (Ref x) (Ref y) = f x y
+
+ refEq :: forall a. Ref a -> Ref a -> Boolean
+ refEq = liftRef unsafeRefEq
+
+ refIneq :: forall a. Ref a -> Ref a -> Boolean
+ refIneq = liftRef unsafeRefIneq
+
+ instance eqRef :: Eq (Ref a) where
+ (==) = refEq
+ (/=) = refIneq
+
module Data.Array.Unsafe where
head :: forall a. [a] -> a
@@ -677,7 +694,7 @@ module Data.Tuple where
data Tuple a b = Tuple a b
- instance (Prelude.Show a, Prelude.Show b) => Prelude.Show (Tuple a b) where
+ instance showTuple :: (Show a, Show b) => Show (Tuple a b) where
show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"
curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
@@ -931,6 +948,8 @@ module Math where
module Control.Monad.Eff where
+ import Prelude
+
foreign import data Eff :: # ! -> * -> *
foreign import retEff "function retEff(a) {\
@@ -953,7 +972,7 @@ module Control.Monad.Eff where
\ return f();\
\}" :: forall a. Pure a -> a
- instance Prelude.Monad (Eff e) where
+ instance monadEff :: Monad (Eff e) where
return = retEff
(>>=) = bindEff
@@ -996,6 +1015,14 @@ module Control.Monad.Eff where
\ };\
\}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}
+module Control.Monad.Eff.Unsafe where
+
+ import Control.Monad.Eff
+
+ foreign import unsafeInterleaveEff
+ "function unsafeInterleaveEff(f) {\
+ \ return f;\
+ \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
module Random where
@@ -1088,7 +1115,7 @@ module Debug.Trace where
\ };\
\}" :: forall r. String -> Eff (trace :: Trace | r) {}
- print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}
+ print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
print o = trace (show o)
module Control.Monad.ST where
diff --git a/psci/Main.hs b/psci/Main.hs
index d29d294..4c1d3a9 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -84,7 +84,7 @@ updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modu
-- Updates the state to have more let bindings.
--
updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState
-updateLets name st = st { psciLetBindings = psciLetBindings st ++ [name] }
+updateLets name st = st { psciLetBindings = name : psciLetBindings st }
-- File helpers
-- |
@@ -194,30 +194,32 @@ options = P.Options True False True (Just "Main") True "PS" []
-- |
-- Makes a volatile module to execute the current expression.
--
-createTemporaryModule :: Bool -> [P.ModuleName] -> [P.Value -> P.Value] -> P.Value -> P.Module
-createTemporaryModule exec imports lets value =
+createTemporaryModule :: Bool -> PSCiState -> P.Value -> P.Module
+createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value =
let
moduleName = P.ModuleName [P.ProperName "Main"]
importDecl m = P.ImportDeclaration m Nothing
traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
- value' = foldr ($) value lets
- itDecl = P.ValueDeclaration (P.Ident "it") [] Nothing value'
- mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))))
+ itValue = foldl (\x f -> f x) value lets
+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
+ itDecl = P.ValueDeclaration (P.Ident "it") [] Nothing itValue
+ mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing mainValue
+ decls = if exec then [itDecl, mainDecl] else [itDecl]
in
- P.Module moduleName $ map importDecl imports ++ if exec then [itDecl, mainDecl] else [itDecl]
+ P.Module moduleName $ map importDecl imports ++ decls
-- |
-- Takes a value declaration and evaluates it with the current state.
--
handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
handleDeclaration value st = do
- let m = createTemporaryModule True (psciImportedModuleNames st) (psciLetBindings st) value
+ let m = createTemporaryModule True st value
case P.compile options (psciLoadedModules st ++ [m]) of
Left err -> outputStrLn err
Right (js, _, _) -> do
process <- lift . lift $ findNodeProcess
- result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process
+ result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process
case result of
Just (ExitSuccess, out, _) -> outputStrLn out
Just (ExitFailure _, _, err) -> outputStrLn err
@@ -228,7 +230,7 @@ handleDeclaration value st = do
--
handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
handleTypeOf value st = do
- let m = createTemporaryModule False (psciImportedModuleNames st) (psciLetBindings st) value
+ let m = createTemporaryModule False st value
case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of
Left err -> outputStrLn err
Right (_, _, env') ->
@@ -257,9 +259,9 @@ getCommand = do
--
handleCommand :: Command -> InputT (StateT PSCiState IO) ()
handleCommand (Expression val) = lift get >>= handleDeclaration val
-handleCommand (Let l) = lift $ modify (updateLets l)
handleCommand Help = outputStrLn helpMessage
handleCommand (Import moduleName) = lift $ modify (updateImports moduleName)
+handleCommand (Let l) = lift $ modify (updateLets l)
handleCommand (LoadFile filePath) = do
absPath <- lift . lift $ expandTilde filePath
exists <- lift . lift $ doesFileExist absPath
@@ -269,12 +271,11 @@ handleCommand (LoadFile filePath) = do
else
outputStrLn $ "Couldn't locate: " ++ filePath
handleCommand Reset = do
- preludeFilename <- lift . lift $ getPreludeFilename
files <- psciImportedFilenames <$> lift get
- modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) (preludeFilename : files)
+ modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) files
case modulesOrFirstError of
Left err -> lift . lift $ putStrLn err >> exitFailure
- Right modules -> lift $ put (PSCiState (preludeFilename : files) defaultImports modules [])
+ Right modules -> lift $ put (PSCiState files defaultImports modules [])
handleCommand (TypeOf val) = lift get >>= handleTypeOf val
handleCommand _ = outputStrLn "Unknown command"
diff --git a/purescript.cabal b/purescript.cabal
index 37b7294..f1a44f2 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.2.1
+version: 0.4.3
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -43,6 +43,7 @@ library
Language.PureScript.Sugar.Operators
Language.PureScript.Sugar.TypeClasses
Language.PureScript.Sugar.Let
+ Language.PureScript.Sugar.Names
Language.PureScript.CodeGen
Language.PureScript.CodeGen.Common
Language.PureScript.CodeGen.Externs
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
index f8f45b3..508dd6c 100644
--- a/src/Data/Generics/Extras.hs
+++ b/src/Data/Generics/Extras.hs
@@ -47,17 +47,28 @@ everywhereM' f x = do
-- > go locals lam@(Lam local _) = (local : locals, lam)
-- > go locals other = (locals, other)
--
-everywhereWithContext' :: (Data d) => s -> (forall d1. (Data d1) => s -> d1 -> (s, d1)) -> d -> d
-everywhereWithContext' s0 f x =
- let (s, y) = f s0 x in
- gmapT (everywhereWithContext' s f) y
+everywhereWithContextM' :: (Monad m, Data d) => s -> (forall d1. (Data d1) => s -> d1 -> m (s, d1)) -> d -> m d
+everywhereWithContextM' s0 f x = do
+ (s, y) <- f s0 x
+ gmapM (everywhereWithContextM' s f) y
-- |
-- Make a stateful transformation function
--
-mkS :: (Data a, Data b) => (s -> a -> (s, a)) -> s -> b -> (s, b)
-mkS f s b = fromMaybe (s, b) $ do
- a <- cast b
- let (s', a') = f s a
- b' <- cast a'
- return (s', b')
+mkS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> s -> b -> m (s, b)
+mkS = extS (curry return)
+
+-- |
+-- Extend a stateful transformation function
+--
+extS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> (s -> b -> m (s, b)) -> (s -> a -> m (s, a))
+extS f g s a = do
+ (s', a') <- f s a
+ case cast a' of
+ Just b -> do
+ (s'', b') <- g s' b
+ case cast b' of
+ Just a'' -> return (s'', a'')
+ Nothing -> return (s', a')
+ Nothing -> return (s', a')
+
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index facf5e6..c6023b0 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -42,7 +42,7 @@ declToPs path env (BindingGroupDeclaration vals) =
(ty, _) <- M.lookup (path, name) $ names env
return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
declToPs path env (DataDeclaration name _ _) = maybeToList $ do
- (kind, _) <- M.lookup (path, name) $ types env
+ kind <- M.lookup (Qualified (Just path) name) $ types env
return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
declToPs _ _ (ExternDataDeclaration name kind) =
return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index ff9e47a..5bd62bd 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -43,7 +43,6 @@ import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
import Language.PureScript.CodeGen.Optimize
import Language.PureScript.CodeGen.Common
-import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)
-- |
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
@@ -121,10 +120,6 @@ 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 "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 m id (Qualified (Just aliasModule) aliasIdent)
- _ -> JSVar . runProperName $ name
valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name
valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
@@ -194,14 +189,10 @@ varToJs m e qual@(Qualified _ ident) = go qual
where
go qual' = case M.lookup (qualify m qual') (names e) of
Just (_, ty) | isExtern ty -> var ident
- Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)
_ -> case qual' of
Qualified Nothing _ -> var ident
_ -> qualifiedToJS m id qual'
isExtern (Extern ForeignImport) = True
- isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
- Just (_, ty') -> isExtern ty'
- Nothing -> error "Undefined alias in varToJs"
isExtern _ = False
-- |
@@ -216,10 +207,10 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
-- Generate code in the simplified Javascript intermediate representation for pattern match binders
-- and guards.
--
-bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS
+bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS
bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do
valNames <- replicateM (length vals) fresh
- jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd
+ jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd
return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
vals
where
@@ -232,15 +223,6 @@ bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders,
go _ _ _ _ = error "Invalid arguments to bindersToJs"
-- |
--- Collect all names introduced in binders in an expression
---
-binderNames :: (Data d) => d -> [Ident]
-binderNames = everything (++) (mkQ [] go)
- where
- go (VarBinder ident) = [ident]
- go _ = []
-
--- |
-- Generate code in the simplified Javascript intermediate representation for a pattern match
-- binder.
--
@@ -262,7 +244,7 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do
then
return js
else
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))
(JSBlock js)
Nothing]
where
@@ -313,10 +295,10 @@ binderToJs m e varName done (NamedBinder ident binder) = do
--
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
+ let ty = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e
in numConstructors ty == 1
where
- numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.elems $ dataConstructors e
typeConstructor (TypeConstructor qual) = qualify m qual
typeConstructor (ForAll _ ty _) = typeConstructor ty
typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index f99b465..a814759 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -46,8 +46,6 @@ import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Options
import Language.PureScript.CodeGen.Common (identToJs)
-import Language.PureScript.Sugar.TypeClasses
- (mkDictionaryValueName)
import Language.PureScript.Types
-- |
@@ -316,10 +314,7 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
prelude = ModuleName [ProperName "Prelude"]
effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]
-- The name of the type class dictionary for the Monad Eff instance
- Right (Ident effDictName) = mkDictionaryValueName
- effModule
- (Qualified (Just prelude) (ProperName "Monad"))
- [TypeConstructor (Qualified (Just effModule) (ProperName "Eff"))]
+ effDictName = "monadEff"
-- Check if an expression represents the Monad Eff dictionary
isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
@@ -406,67 +401,62 @@ inlineOperator op f = everywhere (mkT convert)
inlineCommonOperators :: JS -> JS
inlineCommonOperators = applyAll
- [ binary "+" "Num" tyNumber Add
- , binary "-" "Num" tyNumber Subtract
- , binary "*" "Num" tyNumber Multiply
- , binary "/" "Num" tyNumber Divide
- , binary "%" "Num" tyNumber Modulus
- , unary "negate" "Num" tyNumber Negate
+ [ binary "numNumber" "+" "Num" tyNumber Add
+ , binary "numNumber" "-" "Num" tyNumber Subtract
+ , binary "numNumber" "*" "Num" tyNumber Multiply
+ , binary "numNumber" "/" "Num" tyNumber Divide
+ , binary "numNumber" "%" "Num" tyNumber Modulus
+ , unary "numNumber" "negate" "Num" tyNumber Negate
- , binary "<" "Ord" tyNumber LessThan
- , binary ">" "Ord" tyNumber GreaterThan
- , binary "<=" "Ord" tyNumber LessThanOrEqualTo
- , binary ">=" "Ord" tyNumber GreaterThanOrEqualTo
+ , binary "ordNumber" "<" "Ord" tyNumber LessThan
+ , binary "ordNumber" ">" "Ord" tyNumber GreaterThan
+ , binary "ordNumber" "<=" "Ord" tyNumber LessThanOrEqualTo
+ , binary "ordNumber" ">=" "Ord" tyNumber GreaterThanOrEqualTo
- , binary "==" "Eq" tyNumber EqualTo
- , binary "/=" "Eq" tyNumber NotEqualTo
- , binary "==" "Eq" tyString EqualTo
- , binary "/=" "Eq" tyString NotEqualTo
- , binary "==" "Eq" tyBoolean EqualTo
- , binary "/=" "Eq" tyBoolean NotEqualTo
+ , binary "eqNumber" "==" "Eq" tyNumber EqualTo
+ , binary "eqNumber" "/=" "Eq" tyNumber NotEqualTo
+ , binary "eqString" "==" "Eq" tyString EqualTo
+ , binary "eqString" "/=" "Eq" tyString NotEqualTo
+ , binary "eqBoolean" "==" "Eq" tyBoolean EqualTo
+ , binary "eqBoolean" "/=" "Eq" tyBoolean NotEqualTo
- , binaryFunction "shl" "Bits" tyNumber ShiftLeft
- , binaryFunction "shr" "Bits" tyNumber ShiftRight
- , binaryFunction "zshr" "Bits" tyNumber ZeroFillShiftRight
- , binary "&" "Bits" tyNumber BitwiseAnd
- , binary "|" "Bits" tyNumber BitwiseOr
- , binary "^" "Bits" tyNumber BitwiseXor
- , unary "complement" "Bits" tyNumber BitwiseNot
+ , binaryFunction "bitsNumber" "shl" "Bits" tyNumber ShiftLeft
+ , binaryFunction "bitsNumber" "shr" "Bits" tyNumber ShiftRight
+ , binaryFunction "bitsNumber" "zshr" "Bits" tyNumber ZeroFillShiftRight
+ , binary "bitsNumber" "&" "Bits" tyNumber BitwiseAnd
+ , binary "bitsNumber" "|" "Bits" tyNumber BitwiseOr
+ , binary "bitsNumber" "^" "Bits" tyNumber BitwiseXor
+ , unary "bitsNumber" "complement" "Bits" tyNumber BitwiseNot
- , binary "&&" "BoolLike" tyBoolean And
- , binary "||" "BoolLike" tyBoolean Or
- , unary "not" "BoolLike" tyBoolean Not
+ , binary "boolLikeBoolean" "&&" "BoolLike" tyBoolean And
+ , binary "boolLikeBoolean" "||" "BoolLike" tyBoolean Or
+ , unary "boolLikeBoolean" "not" "BoolLike" tyBoolean Not
]
where
- binary :: String -> String -> Type -> BinaryOperator -> JS -> JS
- binary opString className classTy op = everywhere (mkT convert)
+ binary :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS
+ binary dictName opString className classTy op = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y
convert other = other
isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
isOp _ = False
- binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS
- binaryFunction fnName className classTy op = everywhere (mkT convert)
+ binaryFunction :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS
+ binaryFunction dictName fnName className classTy op = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y
convert other = other
isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
isOp _ = False
- unary :: String -> String -> Type -> UnaryOperator -> JS -> JS
- unary fnName className classTy op = everywhere (mkT convert)
+ unary :: String -> String -> String -> Type -> UnaryOperator -> JS -> JS
+ unary dictName fnName className classTy op = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict className classTy dict = JSUnary op x
+ convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName className classTy dict = JSUnary op x
convert other = other
isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
isOp _ = False
- isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
- where
- Right (Ident dictName) = mkDictionaryValueName
- (ModuleName [ProperName "Prim"])
- (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))
- [ty]
- isOpDict _ _ _ = False
+ isOpDict dictName className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
+ isOpDict _ _ _ _ = False
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 0f3b297..2afe8fb 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -43,19 +43,20 @@ declarationsByModule :: Environment -> Module -> [(Key, [Key])]
declarationsByModule env (Module moduleName ds) = concatMap go ds
where
go :: Declaration -> [(Key, [Key])]
- go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env moduleName d)]
+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
- go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names'
+ go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
go (DataBindingGroupDeclaration ds') = concatMap go ds'
go _ = []
-dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]
-dependencies env moduleName = nub . everything (++) (mkQ [] values)
+dependencies :: (Data d) => ModuleName -> d -> [Key]
+dependencies moduleName = nub . everything (++) (mkQ [] values)
where
values :: Value -> [Key]
- values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]
- values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]
+ values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
+ values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
+ values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
values _ = []
isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 3d73627..c2f92c6 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -66,6 +66,24 @@ data ForeignImportType
| TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
-- |
+-- An item in a list of explicit imports
+--
+data ImportType
+ -- |
+ -- A type constructor import
+ --
+ = TypeImport ProperName (Maybe [ProperName])
+ -- |
+ -- A declaration import
+ --
+ | NameImport Ident
+ -- |
+ -- A type class import
+ --
+ | TypeClassImport ProperName
+ deriving (Show, D.Data, D.Typeable)
+
+-- |
-- The data type of declarations
--
data Declaration
@@ -108,7 +126,7 @@ data Declaration
-- |
-- A module import (module name, optional set of identifiers to import)
--
- | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
+ | ImportDeclaration ModuleName (Maybe [ImportType])
-- |
-- A type class declaration (name, argument, member declarations)
--
@@ -116,7 +134,7 @@ data Declaration
-- |
-- A type instance declaration (dependencies, class name, instance type, member declarations)
--
- | TypeInstanceDeclaration [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
+ | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
deriving (Show, D.Data, D.Typeable)
-- |
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 6a0f4ee..4827cd2 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -36,8 +36,9 @@ parseDataDeclaration = do
reserved "data"
name <- indented *> properName
tyArgs <- many (indented *> identifier)
- _ <- lexeme $ indented *> P.char '='
- ctors <- sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
+ ctors <- P.option [] $ do
+ _ <- lexeme $ indented *> P.char '='
+ sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
return $ DataDeclaration name tyArgs ctors
parseTypeDeclaration :: P.Parsec String ParseState Declaration
@@ -87,31 +88,40 @@ parseImportDeclaration = do
reserved "import"
indented
moduleName' <- moduleName
- idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)
+ idents <- P.optionMaybe $ parens $ commaSep1 parseExplicitImport
return $ ImportDeclaration moduleName' idents
+parseExplicitImport :: P.Parsec String ParseState ImportType
+parseExplicitImport = NameImport <$> parseIdent
+ <|> do name <- properName
+ dctors <- P.optionMaybe $ parens (Just <$> commaSep1 properName <|> lexeme (P.string "..") *> pure Nothing)
+ return $ maybe (TypeClassImport name) (TypeImport name) dctors
+
parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
parseTypeClassDeclaration = do
reserved "class"
className <- indented *> properName
- idents <- indented *> P.many identifier
- indented *> reserved "where"
- members <- mark (P.many (same *> parseTypeDeclaration))
+ idents <- P.many (indented *> identifier)
+ members <- P.option [] . P.try $ do
+ indented *> reserved "where"
+ mark (P.many (same *> parseTypeDeclaration))
return $ TypeClassDeclaration className idents members
parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
parseTypeInstanceDeclaration = do
reserved "instance"
+ name <- parseIdent <* lexeme (indented *> P.string "::")
deps <- P.optionMaybe $ do
deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
indented
reservedOp "=>"
return deps
className <- indented *> parseQualified properName
- ty <- indented *> P.many parseTypeAtom
- indented *> reserved "where"
- members <- mark (P.many (same *> parseValueDeclaration))
- return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members
+ ty <- P.many (indented *> parseTypeAtom)
+ members <- P.option [] . P.try $ do
+ indented *> reserved "where"
+ mark (P.many (same *> parseValueDeclaration))
+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
-- |
-- Parse a single declaration
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index ad03dd3..aee8427 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -74,11 +74,11 @@ parseCase :: P.Parsec String ParseState Value
parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
<*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
-parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
-parseCaseAlternative = (,,) <$> (return <$> parseBinder)
- <*> P.optionMaybe parseGuard
- <*> (C.indented *> C.reservedOp "->" *> parseValue)
- P.<?> "case alternative"
+parseCaseAlternative :: P.Parsec String ParseState CaseAlternative
+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
+ <*> P.optionMaybe parseGuard
+ <*> (C.indented *> C.reservedOp "->" *> parseValue)
+ P.<?> "case alternative"
parseIfThenElse :: P.Parsec String ParseState Value
parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 6121322..947b46d 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -45,8 +45,9 @@ literals = mkPattern match
match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
match _ = Nothing
-prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
-prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
+prettyPrintCaseAlternative :: CaseAlternative -> String
+prettyPrintCaseAlternative (CaseAlternative binders grd val) =
+ "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val
ifThenElse :: Pattern () Value ((Value, Value), Value)
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 4d4a3d5..e45702d 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -27,6 +27,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S
import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.TypeClasses as S
import Language.PureScript.Sugar.Let as S
+import Language.PureScript.Sugar.Names as S
-- |
-- The desugaring pipeline proceeds as follows:
@@ -45,11 +46,14 @@ import Language.PureScript.Sugar.Let as S
--
-- * Group mutually recursive value and data declarations into binding groups.
--
+-- * Qualify any unqualified names and types
+--
desugar :: [Module] -> Either String [Module]
-desugar = desugarTypeClasses
- >=> rebracket
+desugar = rebracket
>=> desugarDo
+ >=> desugarCasesModule
>=> desugarLetBindings
- >>> desugarCasesModule
+ >>> desugarImports
>=> desugarTypeDeclarationsModule
+ >=> desugarTypeClasses
>=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 00b4732..fa5b6dd 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -52,7 +52,7 @@ createBindingGroups moduleName 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
+ dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
let allIdents = map getIdent values
valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
@@ -83,11 +83,11 @@ usedIdents moduleName = nub . everything (++) (mkQ [] names)
names (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
names _ = []
-usedProperNames :: (Data d) => d -> [ProperName]
-usedProperNames = nub . everything (++) (mkQ [] names)
+usedProperNames :: (Data d) => ModuleName -> d -> [ProperName]
+usedProperNames moduleName = nub . everything (++) (mkQ [] names)
where
names :: Type -> [ProperName]
- names (TypeConstructor (Qualified Nothing name)) = [name]
+ names (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
names _ = []
getIdent :: Declaration -> Ident
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index d748648..a0e605f 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -22,8 +22,8 @@ module Language.PureScript.Sugar.CaseDeclarations (
import Data.List (groupBy)
import Data.Generics (mkT, everywhere)
-import Control.Applicative ((<$>))
-import Control.Monad (forM, join, unless)
+import Control.Applicative
+import Control.Monad ((<=<), forM, join, unless)
import Control.Monad.Error.Class
import Language.PureScript.Names
@@ -44,14 +44,20 @@ desugarAbs = everywhere (mkT replace)
let
ident = head $ unusedNames (binder, val)
in
- Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [([binder], Nothing, val)]
+ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
replace other = other
-- |
-- Replace all top-level binders with case expressions.
--
desugarCases :: [Declaration] -> Either String [Declaration]
-desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
+desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
+ where
+ desugarRest :: [Declaration] -> Either String [Declaration]
+ desugarRest ((TypeInstanceDeclaration name constraints className tys ds) : rest) =
+ (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
+ desugarRest (d : ds) = (:) d <$> desugarRest ds
+ desugarRest [] = pure []
inSameGroup :: Declaration -> Declaration -> Bool
inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
@@ -76,7 +82,7 @@ makeCaseDeclaration ident alternatives =
argPattern = length . fst . head $ alternatives
args = take argPattern $ unusedNames (ident, alternatives)
vars = map (Var . Qualified Nothing) args
- binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]
+ binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]
value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args
in
ValueDeclaration ident [] Nothing value
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index aedbe6d..b76aef1 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -55,8 +55,8 @@ desugarDo = everywhereM (mkM replace)
go (DoNotationBind binder val : rest) = do
rest' <- go rest
let ident = head $ unusedNames rest'
- return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))
+ return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))
go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"
go (DoNotationLet binder val : rest) = do
rest' <- go rest
- return $ Case [val] [([binder], Nothing, rest')]
+ return $ Case [val] [CaseAlternative [binder] Nothing rest']
diff --git a/src/Language/PureScript/Sugar/Let.hs b/src/Language/PureScript/Sugar/Let.hs
index a6c8d63..071cddf 100644
--- a/src/Language/PureScript/Sugar/Let.hs
+++ b/src/Language/PureScript/Sugar/Let.hs
@@ -28,5 +28,5 @@ import Language.PureScript.Declarations
desugarLetBindings :: [Module] -> [Module]
desugarLetBindings = everywhere (mkT go)
where
- go (Let binder value result) = Case [value] [([binder], Nothing, result)]
+ go (Let binder value result) = Case [value] [CaseAlternative [binder] Nothing result]
go other = other
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
new file mode 100644
index 0000000..bba4a06
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -0,0 +1,303 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Sugar.Names
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Sugar.Names (
+ desugarImports
+) where
+
+import Data.Maybe (fromMaybe)
+import Data.Data
+import Data.Generics (extM, mkM, everywhereM)
+import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
+
+import Control.Applicative (Applicative(..), (<$>), (<*>))
+import Control.Monad (foldM)
+import Control.Monad.Error
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+import Language.PureScript.Declarations
+import Language.PureScript.Names
+import Language.PureScript.Types
+import Language.PureScript.Values
+
+-- |
+-- The global export environment - every declaration exported from every module.
+--
+type ExportEnvironment = M.Map ModuleName Exports
+
+-- |
+-- The exported declarations from a module.
+--
+data Exports = Exports
+ -- |
+ -- The types exported from each module
+ --
+ { exportedTypes :: S.Set (ProperName, [ProperName])
+ -- |
+ -- The classes exported from each module
+ --
+ , exportedTypeClasses :: S.Set ProperName
+ -- |
+ -- The values exported from each module
+ , exportedValues :: S.Set Ident
+ --
+ } deriving (Show)
+
+-- |
+-- An imported environment for a particular module. This also contains the module's own members.
+--
+data ImportEnvironment = ImportEnvironment
+ -- |
+ -- Local names for types within a module mapped to to their qualified names
+ --
+ { importedTypes :: M.Map ProperName (Qualified ProperName)
+ -- |
+ -- Local names for data constructors within a module mapped to to their qualified names
+ --
+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
+ -- |
+ -- Local names for classes within a module mapped to to their qualified names
+ --
+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
+ -- |
+ -- Local names for values within a module mapped to to their qualified names
+ --
+ , importedValues :: M.Map Ident (Qualified Ident)
+ } deriving (Show)
+
+-- |
+-- Updates the exports for a module from the global environment. If the module was not previously
+-- present in the global environment, it is created.
+--
+updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment
+updateExportedModule env mn update = do
+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
+ exports' <- update exports
+ return $ M.insert mn exports' env
+
+-- |
+-- Adds an empty module to an ExportEnvironment.
+--
+addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment
+addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env
+
+-- |
+-- Adds a type belonging to a module to the export environment.
+--
+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
+addType env mn name dctors = updateExportedModule env mn $ \m -> do
+ types <- addExport (exportedTypes m) (name, dctors)
+ return $ m { exportedTypes = types }
+
+-- |
+-- Adds a class to the export environment.
+--
+addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
+addTypeClass env mn name = updateExportedModule env mn $ \m -> do
+ classes <- addExport (exportedTypeClasses m) name
+ return $ m { exportedTypeClasses = classes }
+
+-- |
+-- Adds a class to the export environment.
+--
+addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
+addValue env mn name = updateExportedModule env mn $ \m -> do
+ values <- addExport (exportedValues m) name
+ return $ m { exportedValues = values }
+
+-- |
+-- Adds an export to a map of exports of that type.
+--
+addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)
+addExport exports name =
+ if S.member name exports
+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
+ else return $ S.insert name exports
+
+-- |
+-- Replaces all local names with qualified names within a set of modules.
+--
+desugarImports :: [Module] -> Either String [Module]
+desugarImports modules = do
+ exports <- findExports modules
+ mapM (renameInModule' exports) modules
+ where
+ renameInModule' exports m = rethrowForModule m $ do
+ imports <- resolveImports exports m
+ renameInModule imports m
+
+-- |
+-- Rethrow an error with the name of the current module in the case of a failure
+--
+rethrowForModule :: Module -> Either String a -> Either String a
+rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
+
+-- |
+-- Replaces all local names with qualified names within a module.
+--
+renameInModule :: ImportEnvironment -> Module -> Either String Module
+renameInModule imports (Module mn decls) =
+ Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)
+ where
+ updateDecl (TypeInstanceDeclaration name cs (Qualified Nothing cn) ts ds) =
+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
+ updateDecl d = return d
+
+ updateVars :: Declaration -> Either String Declaration
+ updateVars (ValueDeclaration name [] Nothing val) =
+ ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
+ where
+ bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)
+ bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)
+ bindFunctionArgs bound other = return (bound, other)
+ bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
+ bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
+ updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
+ updateVars other = return other
+
+ updateValue (Constructor (Qualified Nothing nm)) =
+ Constructor <$> updateDataConstructorName nm
+ updateValue v = return v
+
+ updateBinder (ConstructorBinder (Qualified Nothing nm) b) =
+ ConstructorBinder <$> updateDataConstructorName nm <*> pure b
+ updateBinder v = return v
+ updateType (TypeConstructor (Qualified Nothing nm)) =
+ TypeConstructor <$> updateTypeName nm
+ updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) =
+ SaturatedTypeSynonym <$> updateTypeName nm <*> mapM updateType tys
+ updateType (ConstrainedType cs t) =
+ ConstrainedType <$> updateConstraints cs <*> pure t
+ updateType t = return t
+ updateConstraints = mapM updateConstraint
+ updateConstraint (Qualified Nothing nm, ts) = (,) <$> updateClassName nm <*> pure ts
+ updateConstraint other = return other
+ updateTypeName = update "type" importedTypes
+ updateClassName = update "type class" importedTypeClasses
+ updateValueName = update "value" importedValues
+ updateDataConstructorName = update "data constructor" importedDataConstructors
+ update t get nm = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show nm ++ "'") return $ M.lookup nm (get imports)
+
+-- |
+-- Finds all exported declarations in a set of modules.
+--
+findExports :: [Module] -> Either String ExportEnvironment
+findExports = foldM addModule M.empty
+ where
+ addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do
+ env' <- addTypeClass env mn tcn
+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
+ addDecl _ env _ = return env
+
+-- |
+-- Type representing a set of declarations being explicitly imported from a module
+--
+type ExplicitImports = [ImportType]
+
+-- |
+-- Finds the imports within a module, mapping the imported module name to an optional set of
+-- explicitly imported declarations.
+--
+findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
+findImports = foldl findImports' M.empty
+ where
+ findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
+ findImports' result _ = result
+
+-- |
+-- Constructs a local environment for a module.
+--
+resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
+resolveImports env (Module currentModule decls) =
+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
+ where
+ -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
+ scope :: M.Map ModuleName (Maybe ExplicitImports)
+ scope = M.insert currentModule Nothing (findImports decls)
+ resolveImport' imp (mn, i) = do
+ m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
+ resolveImport currentModule mn m imp i
+
+-- |
+-- Extends the local environment for a module by resolving an import of another module.
+--
+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
+resolveImport currentModule importModule exp imp i = case i of
+ Nothing -> importAll imp
+ (Just expl) -> foldM importExplicit imp expl
+ where
+
+ -- Import everything from a module
+ importAll :: ImportEnvironment -> Either String ImportEnvironment
+ importAll imp = do
+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeImport name (Just dctors))) imp (S.toList $ exportedTypes exp)
+ imp'' <- foldM (\m name -> importExplicit m (NameImport name)) imp' (S.toList $ exportedValues exp)
+ foldM (\m name -> importExplicit m (TypeClassImport name)) imp'' (S.toList $ exportedTypeClasses exp)
+
+ -- Import something explicitly
+ importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment
+ importExplicit imp (NameImport name) = do
+ checkImportExists "value" values name
+ values' <- updateImports (importedValues imp) name
+ return $ imp { importedValues = values' }
+ importExplicit imp (TypeImport name dctors) = do
+ checkImportExists "type" types name
+ types' <- updateImports (importedTypes imp) name
+ let allDctors = allExportedDataConstructors name
+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
+ return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
+ importExplicit imp (TypeClassImport name) = do
+ checkImportExists "type class" classes name
+ typeClasses' <- updateImports (importedTypeClasses imp) name
+ return $ imp { importedTypeClasses = typeClasses' }
+
+ -- Find all exported data constructors for a given type
+ allExportedDataConstructors :: ProperName -> [ProperName]
+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)
+
+ -- Add something to the ImportEnvironment if it does not already exist there
+ updateImports :: (Ord id, Show id) => M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))
+ updateImports m name = case M.lookup name m of
+ Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
+ Just x@(Qualified (Just mn) _) -> throwError $
+ if mn == currentModule || importModule == currentModule
+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
+
+ -- The available values, types, and classes in the module being imported
+ values = exportedValues exp
+ types = fst `S.map` exportedTypes exp
+ classes = exportedTypeClasses exp
+
+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
+ -- from
+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
+ checkDctorExists names = checkImportExists "data constructor" (S.fromList names)
+
+ -- Check that an explicitly imported item exists in the module it is being imported from
+ checkImportExists :: (Show a, Ord a, Eq a) => String -> S.Set a -> a -> Either String a
+ checkImportExists t exports item =
+ if item `S.member` exports
+ then return item
+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
+
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index f0ad912..1bdc932 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -16,7 +16,6 @@
module Language.PureScript.Sugar.TypeClasses (
desugarTypeClasses,
- mkDictionaryValueName,
mkDictionaryEntryName
) where
@@ -92,11 +91,11 @@ desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
desugarDecl mn d@(TypeClassDeclaration name args members) = do
let tys = map memberToNameAndType members
modify (M.insert (mn, name) (args, tys))
- return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor name args) members
-desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
+ return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members
+desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
desugared <- lift $ desugarCases members
- entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
- dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared
+ entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
+ dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
return $ d : entries ++ [dictDecl]
desugarDecl _ other = return [other]
@@ -108,76 +107,59 @@ typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Dec
typeClassDictionaryDeclaration name args members =
TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))
-typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration
-typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =
+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
+typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
ExternDeclaration TypeClassAccessorImport ident
(Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
- (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty))
-typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
+ (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
+typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
-typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
-typeInstanceDictionaryDeclaration mn deps name tys decls = do
+typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
+typeInstanceDictionaryDeclaration name mn deps className tys decls = do
m <- get
- (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
- $ M.lookup (qualify mn name) m
+ (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right
+ $ M.lookup (qualify mn className) m
let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
- entryName <- lift $ mkDictionaryValueName mn name tys
+ let entryName = Escaped (show name)
memberNames <- mapM (memberToNameAndValue memberTypes) decls
return $ ValueDeclaration entryName [] Nothing
(TypedValue True
(foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])
(quantify (if null deps then
- function unit (foldl TypeApp (TypeConstructor name) tys)
+ function unit (foldl TypeApp (TypeConstructor className) tys)
else
- foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor name) tys) deps))
+ foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor className) tys) deps))
)
where
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 tys ident
+ memberName <- mkDictionaryEntryName name ident
return (identToJs ident, TypedValue False
(foldl 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 tys (ValueDeclaration ident [] _ val) = do
+typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
+typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident [] _ val) = do
m <- get
valTy <- lift $ do (args, members) <- lookupTypeClass m
ty' <- lookupIdent members
return $ replaceAllTypeVars (zip args tys) ty'
- entryName <- mkDictionaryEntryName mn name tys ident
+ entryName <- mkDictionaryEntryName name ident
return $ ValueDeclaration entryName [] Nothing
(TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
where
- lookupTypeClass m = maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn name) m
- lookupIdent members = maybe (Left $ "Type class " ++ show name ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
-typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
+ lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m
+ lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
+typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"
qualifiedToString :: ModuleName -> Qualified ProperName -> String
-qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)
-qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runProperName pn
-
--- |
--- Generate a name for a type class dictionary, based on the module name, class name and type name
---
-mkDictionaryValueName :: ModuleName -> Qualified ProperName -> [Type] -> Either String Ident
-mkDictionaryValueName mn cl tys = do
- tyStr <- mapM (typeToString mn) tys
- return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ intercalate "_" tyStr
-
-typeToString :: ModuleName -> Type -> Either String String
-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"
+qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn
-- |
-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
-- member name
--
-mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> [Type] -> Ident -> Desugar Ident
-mkDictionaryEntryName mn name tys ident = do
- Ident dictName <- lift $ mkDictionaryValueName mn name tys
- return $ Escaped $ dictName ++ "_" ++ identToJs ident
+mkDictionaryEntryName :: Ident -> Ident -> Desugar Ident
+mkDictionaryEntryName dictName ident = return $ Escaped $ show dictName ++ "_" ++ identToJs ident
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 012794b..227ba92 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -41,7 +41,7 @@ import Language.PureScript.Sugar.TypeClasses
addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
addDataType moduleName name args dctors ctorKind = do
env <- getEnv
- putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) ctorKind (types env) }
forM_ dctors $ \(dctor, tys) ->
rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
addDataConstructor moduleName name args dctor tys
@@ -49,29 +49,16 @@ addDataType moduleName name args dctors ctorKind = do
addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
addDataConstructor moduleName name args dctor tys = do
env <- getEnv
- dataConstructorIsNotDefined moduleName dctor
let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
let dctorTy = foldr function retTy tys
let polyType = mkForAll args dctorTy
- putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }
+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) polyType (dataConstructors env) }
addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
addTypeSynonym moduleName name args ty kind = do
env <- getEnv
- putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)
- , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) }
-
-typeIsNotDefined :: ModuleName -> ProperName -> Check ()
-typeIsNotDefined moduleName name = do
- env <- getEnv
- guardWith (show name ++ " is already defined") $
- not $ M.member (moduleName, name) (types env)
-
-dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()
-dataConstructorIsNotDefined moduleName dctor = do
- env <- getEnv
- guardWith (show dctor ++ " is already defined") $
- not $ M.member (moduleName, dctor) (dataConstructors env)
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env)
+ , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
valueIsNotDefined :: ModuleName -> Ident -> Check ()
valueIsNotDefined moduleName name = do
@@ -83,7 +70,7 @@ valueIsNotDefined moduleName name = do
addValue :: ModuleName -> Ident -> Type -> Check ()
addValue moduleName name ty = do
env <- getEnv
- putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
+ putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })
addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
addTypeClassDictionaries entries =
@@ -93,7 +80,7 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
checkTypeClassInstance _ (TypeVar _) = return ()
checkTypeClassInstance m (TypeConstructor ctor) = do
env <- getEnv
- when (canonicalizeType m env ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
+ when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
return ()
checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty
checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"
@@ -115,7 +102,6 @@ typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declar
typeCheckAll _ _ [] = return []
typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
- typeIsNotDefined moduleName name
ctorKind <- kindsOf moduleName name args (concatMap snd dctors)
addDataType moduleName name args dctors ctorKind
ds <- typeCheckAll mainModuleName moduleName rest
@@ -125,11 +111,9 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
let syns = mapMaybe toTypeSynonym tys
let dataDecls = mapMaybe toDataDecl tys
(syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
- forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do
- typeIsNotDefined moduleName name
+ forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->
addDataType moduleName name args dctors ctorKind
- forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
- typeIsNotDefined moduleName name
+ forM_ (zip syns syn_ks) $ \((name, args, ty), kind) ->
addTypeSynonym moduleName name args ty kind
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
@@ -140,7 +124,6 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
toDataDecl _ = Nothing
typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
- typeIsNotDefined moduleName name
kind <- kindsOf moduleName name args [ty]
addTypeSynonym moduleName name args ty kind
ds <- typeCheckAll mainModuleName moduleName rest
@@ -168,8 +151,7 @@ typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = d
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do
env <- getEnv
- guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
- putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env) }
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
@@ -179,7 +161,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty)
guardWith "Expected kind *" $ kind == Star
case M.lookup (moduleName, name) (names env) of
Just _ -> throwError $ show name ++ " is already defined"
- Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })
+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
@@ -189,70 +171,23 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d
return $ d : ds
typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
env <- getEnv
- rethrow errorMessage $ do
- guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
- case idents of
- Nothing -> do
- shadowIdents (map snd $ filterModule (names env)) env
- shadowTypes (map snd $ filterModule (types env)) env
- Just idents' -> do
- shadowIdents (lefts idents') env
- shadowTypes (rights idents') env
- shadowTypeClassInstances env
+ let instances = filter (\tcd ->
+ let Qualified (Just mn) _ = tcdName tcd in
+ moduleName == mn && tcdType tcd == TCDRegular
+ ) (typeClassDictionaries env)
+ forM_ instances $ \tcd -> do
+ let (Qualified _ ident) = tcdName tcd
+ addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]
ds <- typeCheckAll mainModuleName currentModule rest
return $ d : ds
- where
- errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
- filterModule = filter ((== moduleName) . fst) . M.keys
- moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
- shadowIdents idents' env =
- forM_ idents' $ \ident ->
- case (moduleName, ident) `M.lookup` names env of
- Just (_, Alias _ _) -> return ()
- Just (pt, _) -> do
- guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
- modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
- Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
- shadowTypes pns env =
- forM_ pns $ \pn ->
- case (moduleName, pn) `M.lookup` types env of
- Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
- Just (_, DataAlias _ _) -> return ()
- Just (k, _) -> do
- guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
- 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
- forM_ keys $ \dctor ->
- case (moduleName, dctor) `M.lookup` dataConstructors env of
- Just (_, Alias _ _) -> return ()
- Just (ctorTy, _) -> do
- guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
- modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
- Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
- shadowTypeClassInstances env = do
- let instances = filter (\tcd ->
- let Qualified (Just mn) _ = tcdName tcd in
- moduleName == mn && tcdType tcd == TCDRegular
- ) (typeClassDictionaries env)
- forM_ instances $ \tcd -> do
- let (Qualified _ ident) = tcdName tcd
- addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]
- constructs (TypeConstructor (Qualified (Just mn) pn')) pn
- = mn == moduleName && pn' == pn
- constructs (ForAll _ ty _) pn = ty `constructs` pn
- constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn
- constructs (TypeApp ty _) pn = ty `constructs` pn
- constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do
env <- getEnv
ds <- typeCheckAll mainModuleName moduleName rest
- return $ qualifyAllUnqualifiedNames moduleName env d : ds
-typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do
+ return $ d : ds
+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
env <- getEnv
- dictName <- Check . lift $ mkDictionaryValueName moduleName className tys
mapM_ (checkTypeClassInstance moduleName) tys
forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
- addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
- [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular])
+ addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
ds <- typeCheckAll mainModuleName moduleName rest
- return $ qualifyAllUnqualifiedNames moduleName env d : ds
+ return $ d : ds
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 068faf4..570880f 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -133,9 +133,9 @@ infer (TypeVar v) = do
infer (TypeConstructor v) = do
env <- liftCheck getEnv
Just moduleName <- checkCurrentModule <$> get
- case M.lookup (qualify moduleName v) (types env) of
- Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"
- Just (kind, _) -> return kind
+ case M.lookup v (types env) of
+ Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))
+ Just kind -> return kind
infer (TypeApp t1 t2) = do
k0 <- fresh
k1 <- infer t1
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 6d9b73c..d65710c 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -49,10 +49,6 @@ data NameKind
--
| Extern ForeignImportType
-- |
- -- An alias for a value in another module, introduced using an import declaration
- --
- | Alias ModuleName Ident
- -- |
-- A local name introduced using a lambda abstraction, variable introduction or binder
--
| LocalVariable
@@ -62,31 +58,6 @@ data NameKind
| DataConstructor deriving Show
-- |
--- The type of a type declaration
---
-data TypeDeclarationKind
- -- |
- -- A data constructor
- --
- = Data
- -- |
- -- A data type foreign import
- --
- | ExternData
- -- |
- -- A type synonym
- --
- | TypeSynonym
- -- |
- -- An alias for a type in another module, introduced using an import declaration
- --
- | DataAlias ModuleName ProperName
- -- |
- -- A local type name introduced using a forall quantifier
- --
- | LocalTypeVariable deriving Show
-
--- |
-- The @Environment@ defines all values and types which are currently in scope:
--
data Environment = Environment {
@@ -97,15 +68,15 @@ data Environment = Environment {
-- |
-- Type names currently in scope
--
- , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
+ , types :: M.Map (Qualified ProperName) Kind
-- |
-- Data constructors currently in scope, along with their associated data type constructors
--
- , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
+ , dataConstructors :: M.Map (Qualified ProperName) Type
-- |
-- Type synonyms currently in scope
--
- , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
+ , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)
-- |
-- Available type class dictionaries
--
@@ -115,12 +86,12 @@ data Environment = Environment {
-- |
-- The basic types existing in the external javascript environment
--
-jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
-jsTypes = M.fromList [ ((ModuleName [ProperName "Prim"], ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))
- , ((ModuleName [ProperName "Prim"], ProperName "Array"), (FunKind Star Star, ExternData))
- , ((ModuleName [ProperName "Prim"], ProperName "String"), (Star, ExternData))
- , ((ModuleName [ProperName "Prim"], ProperName "Number"), (Star, ExternData))
- , ((ModuleName [ProperName "Prim"], ProperName "Boolean"), (Star, ExternData)) ]
+jsTypes ::M.Map (Qualified ProperName) Kind
+jsTypes = M.fromList [ (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Function"), FunKind Star (FunKind Star Star))
+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array"), FunKind Star Star)
+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "String"), Star)
+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Number"), Star)
+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean"), Star) ]
-- |
-- The initial environment with no values and only the default javascript types defined
@@ -142,7 +113,7 @@ bindNames newNames action = do
-- |
-- Temporarily bind a collection of names to types
--
-bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a
+bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) Kind -> m a -> m a
bindTypes newNames action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
@@ -179,7 +150,7 @@ bindLocalVariables moduleName bindings =
--
bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
bindLocalTypeVariables moduleName bindings =
- bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable)))
+ bindTypes (M.fromList $ flip map bindings $ first $ Qualified (Just moduleName))
-- |
-- Lookup the type of a value by name in the @Environment@
@@ -197,36 +168,9 @@ lookupVariable currentModule (Qualified moduleName var) = do
lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable currentModule (Qualified moduleName name) = do
env <- getEnv
- case M.lookup (fromMaybe currentModule moduleName, name) (types env) of
+ case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
- Just (k, _) -> return k
-
--- |
--- Canonicalize an identifier by resolving any aliases introduced by module imports
---
-canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)
-canonicalize _ _ (Qualified (Just mn) i) = (mn, i)
-canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of
- Just (_, Alias mn' i') -> (mn', i')
- _ -> (mn, i)
-
--- |
--- Canonicalize a type variable by resolving any aliases introduced by module imports
---
-canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
-canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
-canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of
- Just (_, DataAlias mn' pn') -> (mn', pn')
- _ -> (mn, nm)
-
--- |
--- Canonicalize a data constructor by resolving any aliases introduced by module imports
---
-canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
-canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)
-canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of
- Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')
- _ -> (mn, pn)
+ Just k -> return k
-- |
-- State required for type checking:
@@ -322,17 +266,3 @@ liftUnify unify = do
Right (a, ust) -> do
modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
return (a, unifyCurrentSubstitution ust)
-
--- |
--- Replace any unqualified names in a type wit their qualified versionss
---
-qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
-qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
- where
- go :: Type -> Type
- go (TypeConstructor nm) = TypeConstructor $ qualify' nm
- go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args
- go (ConstrainedType constraints ty) = ConstrainedType (map (first qualify') constraints) ty
- go other = other
- qualify' qual = let (mn', pn') = canonicalizeType mn env qual
- in Qualified (Just mn') pn'
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 9c33c45..fb6ae65 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -20,8 +20,9 @@ module Language.PureScript.TypeChecker.Synonyms (
import Language.PureScript.Types
import Language.PureScript.Names
-import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType)
+import Language.PureScript.TypeChecker.Monad (Environment(..))
+import Control.Applicative ((<$>))
import Data.Maybe (fromMaybe)
import Data.Data
import Data.Generics
@@ -32,27 +33,27 @@ import Control.Monad.Error
-- |
-- Build a type substitution for a type synonym
--
-buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)
+buildTypeSubstitution :: Environment -> ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
buildTypeSubstitution env moduleName name n = go n []
where
go :: Int -> [Type] -> Type -> Either String (Maybe Type)
- go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)
- go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name
+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
+ go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
go m args (TypeApp f arg) = go (m - 1) (arg:args) f
go _ _ _ = return Nothing
-- |
-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
--
-saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d
+saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> Qualified ProperName -> Int -> d -> Either String d
saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
where
- replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
+ replace t = fromMaybe t <$> buildTypeSubstitution env moduleName name n t
-- |
-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
--
-saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d
+saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d
saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 0a3a9f2..3252a50 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -109,7 +109,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
- guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)
+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)
unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
t3 `unifyTypes` t5
t4 `unifyTypes` t6
@@ -154,12 +154,6 @@ unifyRows r1 r2 =
unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."
-- |
--- Ensure type constructors are equal after canonicalization
---
-typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
-typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
-
--- |
-- Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
--
@@ -271,7 +265,7 @@ entails moduleName context goal@(className, tys) = do
-- Choose type class dictionaries in scope in the current module
, filterModule tcd
-- Make sure the type class name matches the one we are trying to satisfy
- , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
+ , className' == tcdClassName tcd
-- Make sure the type unifies with the type in the type instance definition
, subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
-- Solve any necessary subgoals
@@ -294,8 +288,6 @@ entails moduleName context goal@(className, tys) = do
filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
filterModule _ = False
- -- Resolve a type class dictionary in scope to an actual value by following any (TCDAlias) pointers
- -- which originated from module imports
canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
@@ -314,7 +306,7 @@ typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String
typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []
typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]
typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
-typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
+typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
@@ -419,7 +411,7 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
Just moduleName <- checkCurrentModule <$> get
dicts <- getTypeClassDictionaries
(_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
- return (foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints)), ty')
+ return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')
instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- |
@@ -437,7 +429,7 @@ replaceVarWithUnknown ident ty = do
replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
replaceAllTypeSynonyms' env moduleName d =
let
- syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
+ syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
in
saturateAllTypeSynonyms env moduleName syns d
@@ -461,7 +453,7 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
--
expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
expandTypeSynonym' env moduleName name args =
- case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
+ case M.lookup name (typeSynonyms env) of
Just (synArgs, body) -> do
let repl = replaceAllTypeVars (zip synArgs args) body
replaceAllTypeSynonyms' env moduleName repl
@@ -540,15 +532,15 @@ infer' (Var var) = do
ConstrainedType constraints ty' -> do
env <- getEnv
dicts <- getTypeClassDictionaries
- return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
+ return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'
_ -> return $ TypedValue True (Var var) ty
infer' v@(Constructor c) = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
- case M.lookup (qualify moduleName c) (dataConstructors env) of
+ case M.lookup c (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just (ty, _) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- return $ TypedValue True v ty'
+ Just ty -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
+ return $ TypedValue True v ty'
infer' (Case vals binders) = do
ts <- mapM infer vals
ret <- fresh
@@ -596,8 +588,8 @@ inferBinder val (VarBinder name) = return $ M.singleton name val
inferBinder val (ConstructorBinder ctor binders) = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
- case M.lookup (qualify moduleName ctor) (dataConstructors env) of
- Just (ty, _) -> do
+ case M.lookup ctor (dataConstructors env) of
+ Just ty -> do
(_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty
go binders fn
where
@@ -640,18 +632,18 @@ inferBinder val (NamedBinder name binder) = do
-- |
-- Check the types of the return values in a set of binders in a case statement
--
-checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> UnifyT Type Check [([Binder], Maybe Guard, Value)]
+checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]
checkBinders _ _ [] = return []
-checkBinders nvals ret ((binders, grd, val):bs) = do
+checkBinders nvals ret (CaseAlternative binders grd val : bs) = do
Just moduleName <- checkCurrentModule <$> get
m1 <- M.unions <$> zipWithM inferBinder nvals binders
r <- bindLocalVariables moduleName (M.toList m1) $ do
val' <- TypedValue True <$> check val ret <*> pure ret
case grd of
- Nothing -> return (binders, Nothing, val')
+ Nothing -> return $ CaseAlternative binders Nothing val'
Just g -> do
g' <- check g tyBoolean
- return (binders, Just g', val')
+ return $ CaseAlternative binders (Just g') val'
rs <- checkBinders nvals ret bs
return $ r : rs
@@ -725,8 +717,7 @@ check' val t@(ConstrainedType constraints ty) = do
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
- (qualifyAllUnqualifiedNames moduleName env constraints)) $
- check val ty
+ constraints) $ check val ty
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
check' val (SaturatedTypeSynonym name args) = do
ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
@@ -806,9 +797,9 @@ check' (Accessor prop val) ty = do
check' (Constructor c) ty = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
- case M.lookup (qualify moduleName c) (dataConstructors env) of
+ case M.lookup c (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just (ty1, _) -> do
+ Just ty1 -> do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
_ <- subsumes Nothing repl ty
return $ TypedValue True (Constructor c) ty
@@ -886,7 +877,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do
env <- getEnv
dicts <- getTypeClassDictionaries
Just moduleName <- checkCurrentModule <$> get
- checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg
+ checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg
checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "
++ prettyPrintType fnTy
++ " to argument " ++ prettyPrintValue arg
@@ -932,7 +923,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
Just moduleName <- checkCurrentModule <$> get
_ <- subsumes' Nothing ty1 ty2
- return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))
+ return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)
subsumes' val (Object r1) (Object r2) = do
let
(ts1, r1') = rowToList r1
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 3add094..03d376a 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -21,6 +21,7 @@ import Language.PureScript.Types
import Language.PureScript.Names
import Data.Data
+import Data.Generics (mkQ, everything)
-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -93,7 +94,7 @@ data Value
-- A case expression. During the case expansion phase of desugaring, top-level binders will get
-- desugared into case expressions, hence the need for guards and multiple binders per branch here.
--
- | Case [Value] [([Binder], Maybe Guard, Value)]
+ | Case [Value] [CaseAlternative]
-- |
-- A value with a type annotation
--
@@ -115,17 +116,22 @@ data Value
| TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
-- |
--- The type of a type class dictionary
+-- An alternative in a case statement
--
-data TypeClassDictionaryType
- -- |
- -- A regular type class dictionary
- --
- = TCDRegular
- -- |
- -- A type class dictionary which is an alias for an imported dictionary from another module
- --
- | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
+data CaseAlternative = CaseAlternative
+ { -- |
+ -- A collection of binders with which to match the inputs
+ --
+ caseAlternativeBinders :: [Binder]
+ -- |
+ -- An optional guard
+ --
+ , caseAlternativeGuard :: Maybe Guard
+ -- |
+ -- The result expression
+ --
+ , caseAlternativeResult :: Value
+ } deriving (Show, Data, Typeable)
-- |
-- Data representing a type class dictionary which is in scope
@@ -155,6 +161,19 @@ data TypeClassDictionaryInScope
} deriving (Show, Data, Typeable)
-- |
+-- The type of a type class dictionary
+--
+data TypeClassDictionaryType
+ -- |
+ -- A regular type class dictionary
+ --
+ = TCDRegular
+ -- |
+ -- A type class dictionary which is an alias for an imported dictionary from another module
+ --
+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
+
+-- |
-- A statement in a do-notation block
--
data DoNotationElement
@@ -215,3 +234,14 @@ data Binder
-- A binder which binds its input to an identifier
--
| NamedBinder Ident Binder deriving (Show, Data, Typeable)
+
+
+-- |
+-- Collect all names introduced in binders in an expression
+--
+binderNames :: (Data d) => d -> [Ident]
+binderNames = everything (++) (mkQ [] go)
+ where
+ go (VarBinder ident) = [ident]
+ go (NamedBinder ident _) = [ident]
+ go _ = []
diff --git a/tests/Main.hs b/tests/Main.hs
index fe06cf0..03b0ed0 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -26,7 +26,6 @@ import System.Exit
import System.Process
import System.FilePath (pathSeparator)
import System.Directory (getCurrentDirectory, getDirectoryContents, findExecutable)
-import System.Environment (getArgs)
import Text.Parsec (ParseError)
import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U
@@ -65,16 +64,12 @@ assertCompiles inputFile = do
putStrLn $ "assert " ++ inputFile ++ " compiles successfully"
prelude <- preludeFilename
assert (P.defaultOptions { P.optionsMain = Just "Main", P.optionsNoOptimizations = True, P.optionsModules = ["Main"] }) [prelude, inputFile] $ either (return . Just) $ \js -> do
- args <- getArgs
- if "--run-js" `elem` args
- then do
- process <- findNodeProcess
- result <- traverse (\node -> readProcessWithExitCode node [] js) process
- case result of
- Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
- Just (ExitFailure _, _, err) -> return $ Just err
- Nothing -> return $ Just "Couldn't find node.js executable"
- else return Nothing
+ process <- findNodeProcess
+ result <- traverse (\node -> readProcessWithExitCode node [] js) process
+ case result of
+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
+ Just (ExitFailure _, _, err) -> return $ Just err
+ Nothing -> return $ Just "Couldn't find node.js executable"
findNodeProcess :: IO (Maybe String)
findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names