packages feed

purescript 0.4.2.1 → 0.4.3

raw patch · 27 files changed

+699/−480 lines, 27 files

Files

docgen/Main.hs view
@@ -102,11 +102,11 @@ 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.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
prelude/prelude.purs view
@@ -14,7 +14,7 @@     (<<<) :: 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 @@   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 @@     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 @@     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 @@                            \  return -n;\                            \}" :: Number -> Number -  instance Num Number where+  instance numNumber :: Num Number where     (+) = numAdd     (-) = numSub     (*) = numMul@@ -159,18 +159,6 @@     (==) :: 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 @@                                \  };\                                \}" :: 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 @@                               \  };\                               \}" :: Number -> Number -> Boolean -  instance Ord Number where+  instance ordNumber :: Ord Number where     (<) = numLess     (>) = numGreater     (<=) = numLessEq@@ -299,7 +283,7 @@                                \  return ~n;\                                \}" :: Number -> Number -  instance Bits Number where+  instance bitsNumber :: Bits Number where     (&) = numAnd     (|) = numOr     (^) = numXor@@ -340,7 +324,7 @@                          \  return !b;\                          \}" :: Boolean -> Boolean -  instance BoolLike Boolean where+  instance boolLikeBoolean :: BoolLike Boolean where     (&&) = boolAnd     (||) = boolOr     not = boolNot@@ -364,11 +348,11 @@     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 @@   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 @@   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 @@   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 @@                       \  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 @@     \  };\     \}":: 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 @@     \  };\     \}":: 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 @@   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 @@   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 @@    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 Control.Monad.Eff where +  import Prelude+   foreign import data Eff :: # ! -> * -> *    foreign import retEff "function retEff(a) {\@@ -953,7 +972,7 @@                          \  return f();\                          \}" :: forall a. Pure a -> a -  instance Prelude.Monad (Eff e) where+  instance monadEff :: Monad (Eff e) where     return = retEff     (>>=) = bindEff @@ -996,7 +1015,15 @@                           \  };\                           \}" :: 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    import Control.Monad.Eff@@ -1088,7 +1115,7 @@                        \  };\                        \}" :: 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
psci/Main.hs view
@@ -84,7 +84,7 @@ -- 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 @@ -- | -- 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 @@ -- 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 @@ -- 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 @@   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"
purescript.cabal view
@@ -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 @@                      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
src/Data/Generics/Extras.hs view
@@ -47,17 +47,28 @@ -- >   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')+
src/Language/PureScript/CodeGen/Externs.hs view
@@ -42,7 +42,7 @@     (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
src/Language/PureScript/CodeGen/JS.hs view
@@ -43,7 +43,6 @@ 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 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 @@   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 @@ -- 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 @@     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 @@   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 @@ -- 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
src/Language/PureScript/CodeGen/Optimize.hs view
@@ -46,8 +46,6 @@ 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 @@   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 @@  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
src/Language/PureScript/DeadCodeElimination.hs view
@@ -43,19 +43,20 @@ 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
src/Language/PureScript/Declarations.hs view
@@ -66,6 +66,24 @@   | 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 @@   -- |   -- 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 @@   -- |   -- 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)  -- |
src/Language/PureScript/Parser/Declarations.hs view
@@ -36,8 +36,9 @@   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 @@   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
src/Language/PureScript/Parser/Values.hs view
@@ -74,11 +74,11 @@ 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)
src/Language/PureScript/Pretty/Values.hs view
@@ -45,8 +45,9 @@   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)
src/Language/PureScript/Sugar.hs view
@@ -27,6 +27,7 @@ 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 @@ -- --  * 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
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -52,7 +52,7 @@   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 @@   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
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -22,8 +22,8 @@ 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 @@     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 @@     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
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -55,8 +55,8 @@   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']
src/Language/PureScript/Sugar/Let.hs view
@@ -28,5 +28,5 @@ 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
+ src/Language/PureScript/Sugar/Names.hs view
@@ -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) ++ "'"+
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -16,7 +16,6 @@  module Language.PureScript.Sugar.TypeClasses (   desugarTypeClasses,-  mkDictionaryValueName,   mkDictionaryEntryName ) where @@ -92,11 +91,11 @@ 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 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
src/Language/PureScript/TypeChecker.hs view
@@ -41,7 +41,7 @@ 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 @@ 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 @@ 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 _ (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 _ _ [] = 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 @@     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 @@   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 @@   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 @@     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 @@   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
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -133,9 +133,9 @@ 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
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -49,10 +49,6 @@   --   | 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 @@   | 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 @@   -- |   -- 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 @@ -- | -- 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 @@ -- | -- 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 @@ -- 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 @@ 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 @@     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'
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -20,8 +20,9 @@  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 @@ -- | -- 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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -109,7 +109,7 @@   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' 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 @@     -- 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 @@   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 _ _ (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 @@    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 @@ 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 @@ -- 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 @@     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 (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 @@ -- | -- 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 @@     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' (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 @@   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 @@   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
src/Language/PureScript/Values.hs view
@@ -21,6 +21,7 @@ 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 @@   -- 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 @@   | 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 @@     } 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 @@   -- 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 _ = []
tests/Main.hs view
@@ -26,7 +26,6 @@ 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 @@   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