packages feed

purescript 0.2.9.2 → 0.2.10

raw patch · 22 files changed

+457/−460 lines, 22 files

Files

purescript.cabal view
@@ -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
src/Language/PureScript.hs view
@@ -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
− src/Language/PureScript/BindingGroups.hs 
@@ -1,98 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.BindingGroups--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- 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"
− src/Language/PureScript/CaseDeclarations.hs 
@@ -1,67 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CaseDeclarations--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- 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)-
src/Language/PureScript/CodeGen/Externs.hs view
@@ -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) =
src/Language/PureScript/CodeGen/JS.hs view
@@ -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))
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -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
src/Language/PureScript/Declarations.hs view
@@ -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])
− src/Language/PureScript/DoNotation.hs 
@@ -1,52 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.DoNotation--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- 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')]
− src/Language/PureScript/Operators.hs 
@@ -1,125 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Operators--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- 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)-           ]-
src/Language/PureScript/Parser/Declarations.hs view
@@ -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 =
src/Language/PureScript/Pretty/JS.hs view
@@ -124,6 +124,7 @@     [ return $ lbl ++ ": "     , prettyPrintJS' js     ]+  match (JSRaw js) = return js   match _ = mzero  targetToJs :: JSAssignment -> String
+ src/Language/PureScript/Sugar.hs view
@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Sugar (desugar, module S) where++import Control.Monad++import Language.PureScript.Declarations++import Language.PureScript.Sugar.Operators as S+import Language.PureScript.Sugar.DoNotation as S+import Language.PureScript.Sugar.CaseDeclarations as S+import Language.PureScript.Sugar.TypeDeclarations as S+import Language.PureScript.Sugar.BindingGroups as S++desugar :: [Module] -> Either String [Module]+desugar = rebracket+          >=> desugarDo+          >=> desugarCasesModule+          >=> desugarTypeDeclarationsModule+          >=> return . createBindingGroupsModule
+ src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -0,0 +1,98 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.BindingGroups+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- 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"
+ src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CaseDeclarations+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- 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)+
+ src/Language/PureScript/Sugar/DoNotation.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar.DoNotation+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- 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')]
+ src/Language/PureScript/Sugar/Operators.hs view
@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar.Operators+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- 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)+           ]+
+ src/Language/PureScript/Sugar/TypeDeclarations.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Sugar.TypeDeclarations+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- 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 []
src/Language/PureScript/TypeChecker.hs view
@@ -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
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -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)
src/Language/PureScript/TypeChecker/Types.hs view
@@ -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
− src/Language/PureScript/TypeDeclarations.hs 
@@ -1,35 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.TypeDeclarations--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- 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 []