diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.2.9.2 +version: 0.2.10 cabal-version: >=1.8 build-type: Simple license: MIT @@ -18,18 +18,27 @@ directory -any, filepath -any, mtl -any, parsec -any, syb -any, transformers -any, utf8-string -any exposed-modules: Data.Generics.Extras - Language.PureScript.Options Language.PureScript + Language.PureScript.Options + Language.PureScript.Declarations + Language.PureScript.Kinds + Language.PureScript.Names + Language.PureScript.Types + Language.PureScript.Unknown + Language.PureScript.Values + Language.PureScript.Scope + Language.PureScript.Sugar + Language.PureScript.Sugar.CaseDeclarations + Language.PureScript.Sugar.DoNotation + Language.PureScript.Sugar.TypeDeclarations + Language.PureScript.Sugar.BindingGroups + Language.PureScript.Sugar.Operators Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST Language.PureScript.CodeGen.Monad Language.PureScript.CodeGen.Optimize - Language.PureScript.Declarations - Language.PureScript.Kinds - Language.PureScript.Names - Language.PureScript.Operators Language.PureScript.Parser Language.PureScript.Parser.Common Language.PureScript.Parser.Declarations @@ -48,14 +57,6 @@ Language.PureScript.TypeChecker.Monad Language.PureScript.TypeChecker.Synonyms Language.PureScript.TypeChecker.Types - Language.PureScript.Types - Language.PureScript.Unknown - Language.PureScript.Values - Language.PureScript.CaseDeclarations - Language.PureScript.DoNotation - Language.PureScript.TypeDeclarations - Language.PureScript.BindingGroups - Language.PureScript.Scope exposed: True buildable: True hs-source-dirs: src diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -23,24 +23,15 @@ import Language.PureScript.CodeGen as P import Language.PureScript.TypeChecker as P import Language.PureScript.Pretty as P -import Language.PureScript.Operators as P -import Language.PureScript.CaseDeclarations as P -import Language.PureScript.TypeDeclarations as P -import Language.PureScript.BindingGroups as P -import Language.PureScript.DoNotation as P +import Language.PureScript.Sugar as P import Language.PureScript.Options as P import Data.List (intercalate) -import Control.Monad (forM_, (>=>)) +import Control.Monad (forM_) compile :: Options -> [Module] -> Either String (String, String, Environment) compile opts ms = do - bracketted <- rebracket ms - desugared <- desugarDo - >=> desugarCasesModule - >=> desugarTypeDeclarationsModule - >=> (return . createBindingGroupsModule) - $ bracketted + desugared <- desugar ms (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls let js = prettyPrintJS . map (optimize opts) . concatMap (flip (moduleToJs opts) env) $ desugared let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared diff --git a/src/Language/PureScript/BindingGroups.hs b/src/Language/PureScript/BindingGroups.hs deleted file mode 100644 --- a/src/Language/PureScript/BindingGroups.hs +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.BindingGroups --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module Language.PureScript.BindingGroups ( - createBindingGroups, - createBindingGroupsModule -) where - -import Data.Data -import Data.Graph -import Data.Generics -import Data.List (nub, intersect) - -import Language.PureScript.Declarations -import Language.PureScript.Names -import Language.PureScript.Values -import Language.PureScript.Types - -createBindingGroupsModule :: [Module] -> [Module] -createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds) - -createBindingGroups :: [Declaration] -> [Declaration] -createBindingGroups ds = - let - values = filter isValueDecl ds - dataDecls = filter isDataDecl ds - nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds - allProperNames = map getProperName dataDecls - dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls - dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts - allIdents = map getIdent values - valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values - bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts - in - dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls - -usedIdents :: (Data d) => d -> [Ident] -usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS) - where - namesV :: Value -> [Ident] - namesV (Var (Qualified Nothing name)) = [name] - namesV _ = [] - namesS :: Statement -> [Ident] - namesS (VariableIntroduction name _) = [name] - namesS _ = [] - -usedProperNames :: (Data d) => d -> [ProperName] -usedProperNames = nub . everything (++) (mkQ [] names) - where - names :: Type -> [ProperName] - names (TypeConstructor (Qualified Nothing name)) = [name] - names _ = [] - -isValueDecl :: Declaration -> Bool -isValueDecl (ValueDeclaration _ _ _ _) = True -isValueDecl _ = False - -isDataDecl :: Declaration -> Bool -isDataDecl (DataDeclaration _ _ _) = True -isDataDecl _ = False - -getIdent :: Declaration -> Ident -getIdent (ValueDeclaration ident _ _ _) = ident -getIdent _ = error "Expected ValueDeclaration" - -getProperName :: Declaration -> ProperName -getProperName (DataDeclaration pn _ _) = pn -getProperName _ = error "Expected DataDeclaration" - -toBindingGroup :: SCC Declaration -> Declaration -toBindingGroup (AcyclicSCC d) = d -toBindingGroup (CyclicSCC [d]) = d -toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds' - -toDataBindingGroup :: SCC Declaration -> Declaration -toDataBindingGroup (AcyclicSCC d) = d -toDataBindingGroup (CyclicSCC [d]) = d -toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds' - -fromValueDecl :: Declaration -> (Ident, Value) -fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val) -fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared" -fromValueDecl _ = error "Expected ValueDeclaration" - -fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe Type)]) -fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors) -fromDataDecl _ = error "Expected DataDeclaration" diff --git a/src/Language/PureScript/CaseDeclarations.hs b/src/Language/PureScript/CaseDeclarations.hs deleted file mode 100644 --- a/src/Language/PureScript/CaseDeclarations.hs +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CaseDeclarations --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module Language.PureScript.CaseDeclarations ( - desugarCases, - desugarCasesModule -) where - -import Data.List (groupBy) -import Control.Applicative ((<$>)) -import Control.Monad (forM, join, unless) -import Control.Monad.Error.Class - -import Language.PureScript.Names -import Language.PureScript.Values -import Language.PureScript.Declarations -import Language.PureScript.Scope - -desugarCasesModule :: [Module] -> Either String [Module] -desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds - -desugarCases :: [Declaration] -> Either String [Declaration] -desugarCases = fmap join . mapM toDecls . groupBy inSameGroup - -inSameGroup :: Declaration -> Declaration -> Bool -inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2 -inSameGroup _ _ = False - -toDecls :: [Declaration] -> Either String [Declaration] -toDecls d@[ValueDeclaration _ [] Nothing _] = return d -toDecls ds@(ValueDeclaration ident bs _ _ : _) = do - let tuples = map toTuple ds - unless (all ((== map length bs) . map length . fst) tuples) $ - throwError $ "Argument list lengths differ in declaration " ++ show ident - return [makeCaseDeclaration ident tuples] -toDecls ds = return ds - -toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value)) -toTuple (ValueDeclaration _ bs g val) = (bs, (g, val)) -toTuple _ = error "Not a value declaration" - -makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration -makeCaseDeclaration ident alternatives = - let - argPattern = map length . fst . head $ alternatives - args = take (sum argPattern) $ unusedNames (ident, alternatives) - vars = map (\arg -> Var (Qualified Nothing arg)) args - binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ] - value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args) - in - ValueDeclaration ident [] Nothing value - -rearrange :: [Int] -> [a] -> [[a]] -rearrange [] _ = [] -rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs) - diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs --- a/src/Language/PureScript/CodeGen/Externs.hs +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -40,8 +40,6 @@ declToPs path env (DataDeclaration name _ _) = maybeToList $ do (kind, _) <- M.lookup (path, name) $ types env return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind -declToPs _ _ (ExternMemberDeclaration member name ty) = - return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty declToPs _ _ (ExternDataDeclaration name kind) = return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind declToPs _ _ (TypeSynonymDeclaration name args ty) = diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -23,7 +23,7 @@ import Control.Arrow (second) import Control.Monad (replicateM, forM) -import Language.PureScript.TypeChecker (Environment, names) +import Language.PureScript.TypeChecker (Environment(..), NameKind(..)) import Language.PureScript.Values import Language.PureScript.Names import Language.PureScript.Scope @@ -32,17 +32,23 @@ import Language.PureScript.CodeGen.Monad import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST as AST -import Language.PureScript.TypeChecker.Monad (NameKind(..)) import Language.PureScript.Types moduleToJs :: Options -> Module -> Environment -> [JS] moduleToJs opts (Module pname@(ProperName name) decls) env = + let + rawDecls = mapMaybe filterRawDecls decls + in + map JSRaw rawDecls ++ [ JSVariableIntroduction (Ident name) Nothing , JSApp (JSFunction Nothing [Ident name] (JSBlock (concat $ mapMaybe (\decl -> declToJs opts (ModuleName pname) decl env) decls))) [JSAssignment (JSAssignVariable (Ident name)) (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))] ] + where + filterRawDecls (ExternDeclaration _ (Just js) _) = Just js + filterRawDecls _ = Nothing declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS] declToJs opts mp (ValueDeclaration ident _ _ val) e = @@ -53,24 +59,6 @@ [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)), setProperty (identToJs ident) (JSVar ident) mp ] ) vals -declToJs _ mp (ExternMemberDeclaration member ident ty) _ - | returnsFunction ty = - Just [ JSFunction (Just ident) [Ident "value"] (JSBlock - [ JSReturn $ JSApp (JSAccessor "bind" (JSAccessor member (JSVar (Ident "value")))) [JSVar (Ident "value")] - ]), - setProperty (show ident) (JSVar ident) mp ] - | otherwise = - Just [ JSFunction (Just ident) [Ident "value"] (JSBlock - [ JSReturn $ JSAccessor member (JSVar (Ident "value")) - ]), - setProperty (show ident) (JSVar ident) mp ] - where - returnsFunction (Function _ ret) = isFunction ret - returnsFunction (ForAll _ ty') = returnsFunction ty' - returnsFunction _ = error "Expected function type in declToJs" - isFunction (Function _ _) = True - isFunction (ForAll _ ty') = isFunction ty' - isFunction _ = False declToJs _ mp (DataDeclaration _ _ ctors) _ = Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) -> let @@ -94,6 +82,10 @@ valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs) valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps) valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)] +valueToJs _ m e (Constructor (Qualified Nothing name)) = + case M.lookup (m, name) (dataConstructors e) of + Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent) + _ -> JSVar . Ident . runProperName $ name valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) [] valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values)) diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -46,7 +46,8 @@ | JSTypeOf JS | JSLabel String JS | JSBreak String - | JSContinue String deriving (Show, Data, Typeable) + | JSContinue String + | JSRaw String deriving (Show, Data, Typeable) data JSAssignment = JSAssignVariable Ident diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs --- a/src/Language/PureScript/Declarations.hs +++ b/src/Language/PureScript/Declarations.hs @@ -38,8 +38,7 @@ | TypeDeclaration Ident Type | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value | BindingGroupDeclaration [(Ident, Value)] - | ExternDeclaration Ident Type - | ExternMemberDeclaration String Ident Type + | ExternDeclaration Ident (Maybe String) Type | ExternDataDeclaration ProperName Kind | FixityDeclaration Fixity String | ImportDeclaration ModuleName (Maybe [Either Ident ProperName]) diff --git a/src/Language/PureScript/DoNotation.hs b/src/Language/PureScript/DoNotation.hs deleted file mode 100644 --- a/src/Language/PureScript/DoNotation.hs +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.DoNotation --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module Language.PureScript.DoNotation ( - desugarDo -) where - -import Data.Data -import Data.Generics - -import Language.PureScript.Values -import Language.PureScript.Names -import Language.PureScript.Scope - -desugarDo :: (Data d) => d -> Either String d -desugarDo = everywhereM (mkM replace) - where - replace :: Value -> Either String Value - replace (Do monad els) = go monad els - replace other = return other - go :: Value -> [DoNotationElement] -> Either String Value - go _ [] = error "The impossible happened in desugarDo" - go monad [DoNotationReturn val] = return $ App (Accessor "ret" monad) [val] - go _ (DoNotationReturn _ : _) = Left "Return statement must be the last statement in a do block" - go _ [DoNotationValue val] = return val - go monad (DoNotationValue val : rest) = do - rest' <- go monad rest - return $ App (App (Accessor "bind" monad) [val]) [Abs [Ident "_"] rest'] - go _ [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block" - go monad (DoNotationBind NullBinder val : rest) = go monad (DoNotationValue val : rest) - go monad (DoNotationBind (VarBinder ident) val : rest) = do - rest' <- go monad rest - return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] rest'] - go monad (DoNotationBind binder val : rest) = do - rest' <- go monad rest - let ident = head $ unusedNames rest' - return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])] - go _ [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block" - go monad (DoNotationLet binder val : rest) = do - rest' <- go monad rest - return $ Case [val] [([binder], Nothing, rest')] diff --git a/src/Language/PureScript/Operators.hs b/src/Language/PureScript/Operators.hs deleted file mode 100644 --- a/src/Language/PureScript/Operators.hs +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Operators --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE Rank2Types #-} - -module Language.PureScript.Operators ( - rebracket -) where - -import Language.PureScript.Names -import Language.PureScript.Declarations -import Language.PureScript.Values - -import Data.Function (on) -import Data.List (groupBy, sortBy) -import qualified Data.Map as M -import qualified Data.Generics as G -import qualified Data.Generics.Extras as G -import Control.Monad.State -import Control.Applicative -import qualified Text.Parsec as P -import qualified Text.Parsec.Pos as P -import qualified Text.Parsec.Expr as P - -rebracket :: [Module] -> Either String [Module] -rebracket ms = forM ms $ \(Module name ds) -> do - m <- collectFixities (ModuleName name) ds - let opTable = customOperatorTable m - ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds - return $ Module name $ G.everywhere (G.mkT removeParens) ds' - -removeParens :: Value -> Value -removeParens (Parens val) = val -removeParens val = val - -customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -customOperatorTable fixities = - let - applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2] - userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities - sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns) - groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted - in - map (map (\(name, f, _, a) -> (name, f, a))) groups - -type Chain = [Either Value (Qualified Ident)] - -matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value -matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val - where - parseChains :: Value -> Either String Value - parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b) - parseChains other = return other - extendChain :: Value -> Chain - extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r - extendChain other = [Left other] - bracketChain :: Chain -> Either String Value - bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" - opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops - ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]] - -toAssoc :: Associativity -> P.Assoc -toAssoc Infixl = P.AssocLeft -toAssoc Infixr = P.AssocRight - -parseValue :: P.Parsec Chain () Value -parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P. "expression" - -parseOp :: P.Parsec Chain () (Qualified Ident) -parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P. "operator" - -matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () () -matchOp moduleName op = do - ident <- parseOp - guard (qualify moduleName ident == qualify moduleName op) - -collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity) -collectFixities = go M.empty - where - go :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity) - go m _ [] = return m - go m moduleName (FixityDeclaration fixity name : rest) = do - let qual = Qualified (Just moduleName) (Op name) - when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name) - go (M.insert qual fixity m) moduleName rest - go m moduleName (_:ds) = go m moduleName ds - -globalOp :: String -> Qualified Ident -globalOp = Qualified Nothing . Op - -builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)] -builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl) - , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl) - , (globalOp ">", Binary GreaterThan, 3, Infixl) - , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl) - , (globalOp "!!", flip Indexer, 4, Infixl) - , (globalOp "*", Binary Multiply, 5, Infixl) - , (globalOp "/", Binary Divide, 5, Infixl) - , (globalOp "%", Binary Modulus, 5, Infixl) - , (globalOp "++", Binary Concat, 6, Infixr) - , (globalOp "+", Binary Add, 7, Infixl) - , (globalOp "-", Binary Subtract, 7, Infixl) - , (globalOp "<<", Binary ShiftLeft, 8, Infixl) - , (globalOp ">>", Binary ShiftRight, 8, Infixl) - , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl) - , (globalOp "==", Binary EqualTo, 9, Infixl) - , (globalOp "!=", Binary NotEqualTo, 9, Infixl) - , (globalOp "&", Binary BitwiseAnd, 10, Infixl) - , (globalOp "^", Binary BitwiseXor, 10, Infixl) - , (globalOp "|", Binary BitwiseOr, 10, Infixl) - , (globalOp "&&", Binary And, 11, Infixr) - , (globalOp "||", Binary Or, 11, Infixr) - ] - diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -65,10 +65,8 @@ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName) <*> (lexeme (indented *> P.string "::") *> parseKind) <|> ExternDeclaration <$> parseIdent - <*> (lexeme (indented *> P.string "::") *> parsePolyType) - <|> ExternMemberDeclaration <$> (P.try (reserved "member") *> indented *> stringLiteral) - <*> (indented *> parseIdent) - <*> (lexeme (indented *> P.string "::") *> parsePolyType)) + <*> P.optionMaybe stringLiteral + <*> (lexeme (indented *> P.string "::") *> parsePolyType)) parseAssociativity :: P.Parsec String ParseState Associativity parseAssociativity = diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -124,6 +124,7 @@ [ return $ lbl ++ ": " , prettyPrintJS' js ] + match (JSRaw js) = return js match _ = mzero targetToJs :: JSAssignment -> String diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Sugar.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Sugar +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.PureScript.Sugar (desugar, module S) where + +import Control.Monad + +import Language.PureScript.Declarations + +import Language.PureScript.Sugar.Operators as S +import Language.PureScript.Sugar.DoNotation as S +import Language.PureScript.Sugar.CaseDeclarations as S +import Language.PureScript.Sugar.TypeDeclarations as S +import Language.PureScript.Sugar.BindingGroups as S + +desugar :: [Module] -> Either String [Module] +desugar = rebracket + >=> desugarDo + >=> desugarCasesModule + >=> desugarTypeDeclarationsModule + >=> return . createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.BindingGroups +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.PureScript.Sugar.BindingGroups ( + createBindingGroups, + createBindingGroupsModule +) where + +import Data.Data +import Data.Graph +import Data.Generics +import Data.List (nub, intersect) + +import Language.PureScript.Declarations +import Language.PureScript.Names +import Language.PureScript.Values +import Language.PureScript.Types + +createBindingGroupsModule :: [Module] -> [Module] +createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds) + +createBindingGroups :: [Declaration] -> [Declaration] +createBindingGroups ds = + let + values = filter isValueDecl ds + dataDecls = filter isDataDecl ds + nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds + allProperNames = map getProperName dataDecls + dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls + dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts + allIdents = map getIdent values + valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values + bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts + in + dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls + +usedIdents :: (Data d) => d -> [Ident] +usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS) + where + namesV :: Value -> [Ident] + namesV (Var (Qualified Nothing name)) = [name] + namesV _ = [] + namesS :: Statement -> [Ident] + namesS (VariableIntroduction name _) = [name] + namesS _ = [] + +usedProperNames :: (Data d) => d -> [ProperName] +usedProperNames = nub . everything (++) (mkQ [] names) + where + names :: Type -> [ProperName] + names (TypeConstructor (Qualified Nothing name)) = [name] + names _ = [] + +isValueDecl :: Declaration -> Bool +isValueDecl (ValueDeclaration _ _ _ _) = True +isValueDecl _ = False + +isDataDecl :: Declaration -> Bool +isDataDecl (DataDeclaration _ _ _) = True +isDataDecl _ = False + +getIdent :: Declaration -> Ident +getIdent (ValueDeclaration ident _ _ _) = ident +getIdent _ = error "Expected ValueDeclaration" + +getProperName :: Declaration -> ProperName +getProperName (DataDeclaration pn _ _) = pn +getProperName _ = error "Expected DataDeclaration" + +toBindingGroup :: SCC Declaration -> Declaration +toBindingGroup (AcyclicSCC d) = d +toBindingGroup (CyclicSCC [d]) = d +toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds' + +toDataBindingGroup :: SCC Declaration -> Declaration +toDataBindingGroup (AcyclicSCC d) = d +toDataBindingGroup (CyclicSCC [d]) = d +toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds' + +fromValueDecl :: Declaration -> (Ident, Value) +fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val) +fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared" +fromValueDecl _ = error "Expected ValueDeclaration" + +fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe Type)]) +fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors) +fromDataDecl _ = error "Expected DataDeclaration" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.CaseDeclarations +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.PureScript.Sugar.CaseDeclarations ( + desugarCases, + desugarCasesModule +) where + +import Data.List (groupBy) +import Control.Applicative ((<$>)) +import Control.Monad (forM, join, unless) +import Control.Monad.Error.Class + +import Language.PureScript.Names +import Language.PureScript.Values +import Language.PureScript.Declarations +import Language.PureScript.Scope + +desugarCasesModule :: [Module] -> Either String [Module] +desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds + +desugarCases :: [Declaration] -> Either String [Declaration] +desugarCases = fmap join . mapM toDecls . groupBy inSameGroup + +inSameGroup :: Declaration -> Declaration -> Bool +inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2 +inSameGroup _ _ = False + +toDecls :: [Declaration] -> Either String [Declaration] +toDecls d@[ValueDeclaration _ [] Nothing _] = return d +toDecls ds@(ValueDeclaration ident bs _ _ : _) = do + let tuples = map toTuple ds + unless (all ((== map length bs) . map length . fst) tuples) $ + throwError $ "Argument list lengths differ in declaration " ++ show ident + return [makeCaseDeclaration ident tuples] +toDecls ds = return ds + +toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value)) +toTuple (ValueDeclaration _ bs g val) = (bs, (g, val)) +toTuple _ = error "Not a value declaration" + +makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration +makeCaseDeclaration ident alternatives = + let + argPattern = map length . fst . head $ alternatives + args = take (sum argPattern) $ unusedNames (ident, alternatives) + vars = map (\arg -> Var (Qualified Nothing arg)) args + binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ] + value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args) + in + ValueDeclaration ident [] Nothing value + +rearrange :: [Int] -> [a] -> [[a]] +rearrange [] _ = [] +rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs) + diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Sugar.DoNotation +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.PureScript.Sugar.DoNotation ( + desugarDo +) where + +import Data.Data +import Data.Generics + +import Language.PureScript.Values +import Language.PureScript.Names +import Language.PureScript.Scope + +desugarDo :: (Data d) => d -> Either String d +desugarDo = everywhereM (mkM replace) + where + replace :: Value -> Either String Value + replace (Do monad els) = go monad els + replace other = return other + go :: Value -> [DoNotationElement] -> Either String Value + go _ [] = error "The impossible happened in desugarDo" + go monad [DoNotationReturn val] = return $ App (Accessor "ret" monad) [val] + go _ (DoNotationReturn _ : _) = Left "Return statement must be the last statement in a do block" + go _ [DoNotationValue val] = return val + go monad (DoNotationValue val : rest) = do + rest' <- go monad rest + return $ App (App (Accessor "bind" monad) [val]) [Abs [Ident "_"] rest'] + go _ [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block" + go monad (DoNotationBind NullBinder val : rest) = go monad (DoNotationValue val : rest) + go monad (DoNotationBind (VarBinder ident) val : rest) = do + rest' <- go monad rest + return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] rest'] + go monad (DoNotationBind binder val : rest) = do + rest' <- go monad rest + let ident = head $ unusedNames rest' + return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])] + go _ [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block" + go monad (DoNotationLet binder val : rest) = do + rest' <- go monad rest + return $ Case [val] [([binder], Nothing, rest')] diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Sugar.Operators +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE Rank2Types #-} + +module Language.PureScript.Sugar.Operators ( + rebracket +) where + +import Language.PureScript.Names +import Language.PureScript.Declarations +import Language.PureScript.Values + +import Data.Function (on) +import Data.List (groupBy, sortBy) +import qualified Data.Map as M +import qualified Data.Generics as G +import qualified Data.Generics.Extras as G +import Control.Monad.State +import Control.Applicative +import qualified Text.Parsec as P +import qualified Text.Parsec.Pos as P +import qualified Text.Parsec.Expr as P + +rebracket :: [Module] -> Either String [Module] +rebracket ms = forM ms $ \(Module name ds) -> do + m <- collectFixities (ModuleName name) ds + let opTable = customOperatorTable m + ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds + return $ Module name $ G.everywhere (G.mkT removeParens) ds' + +removeParens :: Value -> Value +removeParens (Parens val) = val +removeParens val = val + +customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] +customOperatorTable fixities = + let + applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2] + userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities + sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns) + groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted + in + map (map (\(name, f, _, a) -> (name, f, a))) groups + +type Chain = [Either Value (Qualified Ident)] + +matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value +matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val + where + parseChains :: Value -> Either String Value + parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b) + parseChains other = return other + extendChain :: Value -> Chain + extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r + extendChain other = [Left other] + bracketChain :: Chain -> Either String Value + bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" + opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops + ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]] + +toAssoc :: Associativity -> P.Assoc +toAssoc Infixl = P.AssocLeft +toAssoc Infixr = P.AssocRight + +parseValue :: P.Parsec Chain () Value +parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P. "expression" + +parseOp :: P.Parsec Chain () (Qualified Ident) +parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P. "operator" + +matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () () +matchOp moduleName op = do + ident <- parseOp + guard (qualify moduleName ident == qualify moduleName op) + +collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity) +collectFixities = go M.empty + where + go :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity) + go m _ [] = return m + go m moduleName (FixityDeclaration fixity name : rest) = do + let qual = Qualified (Just moduleName) (Op name) + when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name) + go (M.insert qual fixity m) moduleName rest + go m moduleName (_:ds) = go m moduleName ds + +globalOp :: String -> Qualified Ident +globalOp = Qualified Nothing . Op + +builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)] +builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl) + , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl) + , (globalOp ">", Binary GreaterThan, 3, Infixl) + , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl) + , (globalOp "!!", flip Indexer, 4, Infixl) + , (globalOp "*", Binary Multiply, 5, Infixl) + , (globalOp "/", Binary Divide, 5, Infixl) + , (globalOp "%", Binary Modulus, 5, Infixl) + , (globalOp "++", Binary Concat, 6, Infixr) + , (globalOp "+", Binary Add, 7, Infixl) + , (globalOp "-", Binary Subtract, 7, Infixl) + , (globalOp "<<", Binary ShiftLeft, 8, Infixl) + , (globalOp ">>", Binary ShiftRight, 8, Infixl) + , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl) + , (globalOp "==", Binary EqualTo, 9, Infixl) + , (globalOp "!=", Binary NotEqualTo, 9, Infixl) + , (globalOp "&", Binary BitwiseAnd, 10, Infixl) + , (globalOp "^", Binary BitwiseXor, 10, Infixl) + , (globalOp "|", Binary BitwiseOr, 10, Infixl) + , (globalOp "&&", Binary And, 11, Infixr) + , (globalOp "||", Binary Or, 11, Infixr) + ] + diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Sugar.TypeDeclarations +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Language.PureScript.Sugar.TypeDeclarations ( + desugarTypeDeclarations, + desugarTypeDeclarationsModule +) where + +import Control.Applicative +import Control.Monad.Error.Class +import Control.Monad (forM) + +import Language.PureScript.Declarations +import Language.PureScript.Values + +desugarTypeDeclarationsModule :: [Module] -> Either String [Module] +desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds + +desugarTypeDeclarations :: [Declaration] -> Either String [Declaration] +desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' = + desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue val ty) : rest) +desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name +desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds +desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -50,7 +50,7 @@ let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args) let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy let polyType = mkForAll args dctorTy - putEnv $ env { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env) } + putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (polyType, DataConstructor) (dataConstructors env) } addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check () addTypeSynonym moduleName name args ty kind = do @@ -125,24 +125,7 @@ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env) putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) } typeCheckAll moduleName rest -typeCheckAll moduleName (ExternMemberDeclaration member name ty : rest) = do - rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do - env <- getEnv - kind <- kindOf moduleName ty - guardWith "Expected kind *" $ kind == Star - case M.lookup (moduleName, name) (names env) of - Just _ -> throwError $ show name ++ " is already defined" - Nothing -> case ty of - _ | isSingleArgumentFunction ty -> do - putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) - , members = M.insert (moduleName, name) member (members env) }) - | otherwise -> throwError "Foreign member declarations must have function types, with an single argument." - typeCheckAll moduleName rest - where - isSingleArgumentFunction (Function [_] _) = True - isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t - isSingleArgumentFunction _ = False -typeCheckAll moduleName (ExternDeclaration name ty : rest) = do +typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do env <- getEnv kind <- kindOf moduleName ty @@ -183,16 +166,16 @@ Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined") Just (k, _) -> do modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) }) - let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env + let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env forM_ keys $ \dctor -> do guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env case (moduleName, dctor) `M.lookup` dataConstructors env of - Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) }) + Just (ctorTy, _) -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) }) Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined") constructs (TypeConstructor (Qualified (Just mn) pn')) pn = mn == moduleName && pn' == pn constructs (ForAll _ ty) pn = ty `constructs` pn constructs (Function _ ty) pn = ty `constructs` pn constructs (TypeApp ty _) pn = ty `constructs` pn - constructs fn _ = error $ "Invalid arguments to construct" ++ show fn + constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -36,7 +36,8 @@ = Value | Extern | Alias ModuleName Ident - | LocalVariable deriving Show + | LocalVariable + | DataConstructor deriving Show data TypeDeclarationKind = Data @@ -48,7 +49,7 @@ data Environment = Environment { names :: M.Map (ModuleName, Ident) (Type, NameKind) , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) - , dataConstructors :: M.Map (ModuleName, ProperName) Type + , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind) , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type) , members :: M.Map (ModuleName, Ident) String } deriving (Show) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -337,7 +337,7 @@ moduleName <- substCurrentModule `fmap` ask case M.lookup (qualify moduleName c) (dataConstructors env) of Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined" - Just ty -> replaceAllTypeSynonyms ty + Just (ty, _) -> replaceAllTypeSynonyms ty infer' (Case vals binders) = do ts <- mapM infer vals ret <- fresh @@ -450,7 +450,7 @@ env <- getEnv moduleName <- substCurrentModule <$> ask case M.lookup (qualify moduleName ctor) (dataConstructors env) of - Just ty -> do + Just (ty, _) -> do ty `subsumes` val return M.empty _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined" @@ -458,7 +458,7 @@ env <- getEnv moduleName <- substCurrentModule <$> ask case M.lookup (qualify moduleName ctor) (dataConstructors env) of - Just ty -> do + Just (ty, _) -> do fn <- replaceAllVarsWithUnknowns ty case fn of Function [obj] ret -> do @@ -649,7 +649,7 @@ moduleName <- substCurrentModule <$> ask case M.lookup (qualify moduleName c) (dataConstructors env) of Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined" - Just ty1 -> do + Just (ty1, _) -> do repl <- replaceAllTypeSynonyms ty1 repl `subsumes` ty check' val (SaturatedTypeSynonym name args) = do diff --git a/src/Language/PureScript/TypeDeclarations.hs b/src/Language/PureScript/TypeDeclarations.hs deleted file mode 100644 --- a/src/Language/PureScript/TypeDeclarations.hs +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeDeclarations --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module Language.PureScript.TypeDeclarations ( - desugarTypeDeclarations, - desugarTypeDeclarationsModule -) where - -import Control.Applicative -import Control.Monad.Error.Class -import Control.Monad (forM) - -import Language.PureScript.Declarations -import Language.PureScript.Values - -desugarTypeDeclarationsModule :: [Module] -> Either String [Module] -desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds - -desugarTypeDeclarations :: [Declaration] -> Either String [Declaration] -desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' = - desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue val ty) : rest) -desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name -desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds -desugarTypeDeclarations [] = return []