purescript 0.6.2 → 0.6.3

raw patch · 76 files changed

+3215/−2098 lines, 76 filesdep ~optparse-applicativePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: optparse-applicative

API changes (from Hackage documentation)

Files

• examples/failing/Eff.purs +12/−0
• examples/failing/UnderscoreModuleName.purs +3/−0
• examples/passing/CaseInDo.purs +20/−0
• examples/passing/Eff.purs +6/−0
• examples/passing/ForeignInstance.purs +4/−0
• examples/passing/Objects.purs +5/−0
• examples/passing/TypeWildcardsRecordExtension.purs +6/−0
• examples/passing/UnderscoreIdent.purs +9/−0
• hierarchy/Main.hs +4/−4
• prelude/prelude.purs +2/−0
• psc-docs/Main.hs +26/−39
• psc-make/Main.hs +4/−2
• psc/Main.hs +4/−1
• psci/Commands.hs +14/−11
• psci/Main.hs +120/−30
• psci/Parser.hs +47/−77
• purescript.cabal +35/−24
• src/Language/PureScript.hs +41/−40
• src/Language/PureScript/AST/Binders.hs +3/−2
• src/Language/PureScript/AST/Declarations.hs +78/−18
• src/Language/PureScript/AST/Traversals.hs +24/−24
• src/Language/PureScript/CodeGen/Common.hs +0/−193
• src/Language/PureScript/CodeGen/Externs.hs +12/−10
• src/Language/PureScript/CodeGen/JS.hs +183/−216
• src/Language/PureScript/CodeGen/JS/AST.hs +10/−1
• src/Language/PureScript/CodeGen/JS/Common.hs +141/−0
• src/Language/PureScript/CodeGen/JS/Optimizer.hs +76/−0
• src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs +42/−0
• src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +77/−0
• src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +191/−0
• src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +165/−0
• src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +103/−0
• src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +46/−0
• src/Language/PureScript/Comments.hs +25/−0
• src/Language/PureScript/CoreFn.hs +26/−0
• src/Language/PureScript/CoreFn/Ann.hs +37/−0
• src/Language/PureScript/CoreFn/Binders.hs +47/−0
• src/Language/PureScript/CoreFn/Desugar.hs +242/−0
• src/Language/PureScript/CoreFn/Expr.hs +125/−0
• src/Language/PureScript/CoreFn/Literals.hs +45/−0
• src/Language/PureScript/CoreFn/Meta.hs +54/−0
• src/Language/PureScript/CoreFn/Module.hs +30/−0
• src/Language/PureScript/CoreFn/Traversals.hs +85/−0
• src/Language/PureScript/DeadCodeElimination.hs +60/−71
• src/Language/PureScript/Environment.hs +20/−5
• src/Language/PureScript/ModuleDependencies.hs +0/−3
• src/Language/PureScript/Names.hs +2/−2
• src/Language/PureScript/Optimizer.hs +0/−76
• src/Language/PureScript/Optimizer/Blocks.hs +0/−42
• src/Language/PureScript/Optimizer/Common.hs +0/−77
• src/Language/PureScript/Optimizer/Inliner.hs +0/−192
• src/Language/PureScript/Optimizer/MagicDo.hs +0/−162
• src/Language/PureScript/Optimizer/TCO.hs +0/−103
• src/Language/PureScript/Optimizer/Unused.hs +0/−46
• src/Language/PureScript/Parser.hs +1/−0
• src/Language/PureScript/Parser/Common.hs +32/−279
• src/Language/PureScript/Parser/Declarations.hs +132/−126
• src/Language/PureScript/Parser/Kinds.hs +9/−9
• src/Language/PureScript/Parser/Lexer.hs +491/−0
• src/Language/PureScript/Parser/Types.hs +27/−25
• src/Language/PureScript/Pretty/Common.hs +1/−1
• src/Language/PureScript/Pretty/JS.hs +36/−7
• src/Language/PureScript/Pretty/Values.hs +4/−4
• src/Language/PureScript/Renamer.hs +58/−75
• src/Language/PureScript/Sugar/BindingGroups.hs +6/−6
• src/Language/PureScript/Sugar/CaseDeclarations.hs +7/−7
• src/Language/PureScript/Sugar/DoNotation.hs +3/−3
• src/Language/PureScript/Sugar/Names.hs +13/−13
• src/Language/PureScript/Sugar/Operators.hs +1/−1
• src/Language/PureScript/Sugar/TypeClasses.hs +43/−40
• src/Language/PureScript/Sugar/TypeDeclarations.hs +4/−4
• src/Language/PureScript/TypeChecker.hs +18/−14
• src/Language/PureScript/TypeChecker/Entailment.hs +2/−2
• src/Language/PureScript/TypeChecker/Types.hs +5/−5
• src/Language/PureScript/TypeClassDictionaries.hs +1/−1
• src/Language/PureScript/Types.hs +10/−5

@@ -0,0 +1,12 @@+module Main where++import Prelude+import Control.Monad.Eff+import Control.Monad.ST+import Debug.Trace++test = pureST (do+         ref <- newSTRef 0+         trace "ST"+         modifySTRef ref $ \n -> n + 1+         readSTRef ref)

@@ -0,0 +1,3 @@+module Bad_Module where++main = Debug.Trace.trace "Done"

@@ -0,0 +1,20 @@+module Main where++import Debug.Trace+import Control.Monad.Eff++foreign import doIt "function doIt() { global.flag = true; }" :: forall eff. Eff eff Unit++foreign import get "function get() { return global.flag; }" :: forall eff. Eff eff Boolean++set = do+  trace "Testing..."+  case 0 of+    0 -> doIt+    _ -> return unit++main = do+  set+  b <- get+  case b of+    true -> trace "Done"

@@ -14,6 +14,12 @@           modifySTRef ref $ \n -> n + 1           readSTRef ref)) +test3 = pureST (do+          ref <- newSTRef 0+          modifySTRef ref $ \n -> n + 1+          readSTRef ref)+ main = do   test1   Debug.Trace.print test2+  Debug.Trace.print test3

@@ -9,6 +9,10 @@  foreign import instance fooString :: Foo String +foreign import fooString "var fooString = {};" :: Unit+foreign import fooNumber "var fooNumber = {};" :: Unit+foreign import fooArray "var fooArray = {};" :: Unit+ test1 _ = foo [1, 2, 3]  test2 _ = foo "Test"

@@ -26,5 +26,10 @@    test5 = case { "***": 1 } of     { "***" = n } -> n++  test6 = case { "***": 1 } of+               { "***": n } -> n++  test7 {a:    snoog , b     : blah } = blah        main = Debug.Trace.trace "Done"

@@ -0,0 +1,6 @@+module Main where+    +foo :: forall a. {b :: Number | a} -> {b :: Number | _}+foo f = f++main = Debug.Trace.trace "Done"

@@ -0,0 +1,9 @@+module Main where++data Data_type = Con_Structor | Con_2 String++type Type_name = Data_type++done (Con_2 s) = s++main = Debug.Trace.trace (done (Con_2 "Done"))

@@ -55,9 +55,9 @@ runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)  readInput :: FilePath -> IO (Either Par.ParseError [P.Module])-readInput p = do-  text <- U.readFile p-  return $ P.runIndentParser p P.parseModules text+readInput filename = do+  content <- U.readFile filename+  return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]  compile :: HierarchyOptions -> IO () compile (HierarchyOptions input mOutput) = do@@ -84,7 +84,7 @@ superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =   fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]-superClasses (P.PositionedDeclaration _ decl) = superClasses decl+superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl superClasses _ = []  inputFile :: Parser FilePath

@@ -915,3 +915,5 @@                        \  return f;\                        \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a +  pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a+  pureST st = runPure (runST st)

@@ -75,8 +75,8 @@   mapM_ (renderModule showHierarchy) ms  renderModule :: Bool -> P.Module -> Docs-renderModule showHierarchy (P.Module moduleName ds exps) =-  let exported = filter (isExported exps) ds+renderModule showHierarchy mdl@(P.Module moduleName _ exps) =+  let ds = P.exportedDeclarations mdl       hasTypes = any isTypeDeclaration ds       hasTypeclasses = any isTypeClassDeclaration ds       hasTypeclassInstances = any isTypeInstanceDeclaration ds@@ -87,7 +87,7 @@     when hasTypes $ do       headerLevel 3 "Types"       spacer-      renderTopLevel exps (filter isTypeDeclaration exported)+      renderTopLevel exps (filter isTypeDeclaration ds)       spacer     when hasTypeclasses $ do       headerLevel 3 "Type Classes"@@ -95,7 +95,7 @@       when showHierarchy $ do         renderTypeclassImage moduleName         spacer-      renderTopLevel exps (filter isTypeClassDeclaration exported)+      renderTopLevel exps (filter isTypeClassDeclaration ds)       spacer     when hasTypeclassInstances $ do       headerLevel 3 "Type Class Instances"@@ -105,34 +105,9 @@     when hasValues $ do       headerLevel 3 "Values"       spacer-      renderTopLevel exps (filter isValueDeclaration exported)+      renderTopLevel exps (filter isValueDeclaration ds)       spacer -isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool-isExported Nothing _ = True-isExported _ P.TypeInstanceDeclaration{} = True-isExported exps (P.PositionedDeclaration _ d) = isExported exps d-isExported (Just exps) decl = any (matches decl) exps-  where-  matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'-  matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'-  matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'-  matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'-  matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'-  matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'-  matches (P.PositionedDeclaration _ d) r = d `matches` r-  matches d (P.PositionedDeclarationRef _ r) = d `matches` r-  matches _ _ = False--isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool-isDctorExported _ Nothing _ = True-isDctorExported ident (Just exps) ctor = test `any` exps-  where-  test (P.PositionedDeclarationRef _ d) = test d-  test (P.TypeRef ident' Nothing) = ident == ident'-  test (P.TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors-  test _ = False- renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do   renderDeclaration 4 exps decl@@ -152,7 +127,7 @@   let     typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)     typeName = prettyPrintType' typeApp-    exported = filter (isDctorExported name exps . fst) ctors+    exported = filter (P.isDctorExported name exps . fst) ctors   atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")   forM_ exported $ \(ctor, tys) ->     let ctorTy = foldr P.function typeApp tys@@ -177,10 +152,20 @@                           [] -> ""                           cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "   atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)-renderDeclaration n exps (P.PositionedDeclaration _ d) =+renderDeclaration n exps (P.PositionedDeclaration _ com d) = do+  renderComments n com+  spacer   renderDeclaration n exps d renderDeclaration _ _ _ = return () +renderComments :: Int -> [P.Comment] -> Docs+renderComments n cs = mapM_ (atIndent n) ls+  where+  ls = concatMap toLines cs+  +  toLines (P.LineComment s) = [s]+  toLines (P.BlockComment s) = lines s+ toTypeVar :: (String, Maybe P.Kind) -> P.Type toTypeVar (s, Nothing) = P.TypeVar s toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k@@ -201,30 +186,30 @@ getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name getName (P.TypeInstanceDeclaration name _ _ _ _) = show name-getName (P.PositionedDeclaration _ d) = getName d+getName (P.PositionedDeclaration _ _ d) = getName d getName _ = error "Invalid argument to getName"  isValueDeclaration :: P.Declaration -> Bool isValueDeclaration P.TypeDeclaration{} = True isValueDeclaration P.ExternDeclaration{} = True-isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d+isValueDeclaration (P.PositionedDeclaration _ _ d) = isValueDeclaration d isValueDeclaration _ = False  isTypeDeclaration :: P.Declaration -> Bool isTypeDeclaration P.DataDeclaration{} = True isTypeDeclaration P.ExternDataDeclaration{} = True isTypeDeclaration P.TypeSynonymDeclaration{} = True-isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d+isTypeDeclaration (P.PositionedDeclaration _ _ d) = isTypeDeclaration d isTypeDeclaration _ = False  isTypeClassDeclaration :: P.Declaration -> Bool isTypeClassDeclaration P.TypeClassDeclaration{} = True-isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d+isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d isTypeClassDeclaration _ = False  isTypeInstanceDeclaration :: P.Declaration -> Bool isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True-isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d+isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d isTypeInstanceDeclaration _ = False  inputFile :: Parser FilePath@@ -244,8 +229,10 @@ main :: IO () main = execParser opts >>= docgen   where-  opts        = info (helper <*> pscDocsOptions) infoModList+  opts        = info (version <*> helper <*> pscDocsOptions) infoModList   infoModList = fullDesc <> headerInfo <> footerInfo   headerInfo  = header   "psc-docs - Generate Markdown documentation from PureScript extern files"   footerInfo  = footer $ "psc-docs " ++ showVersion Paths.version-+  +  version :: Parser (a -> a)+  version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

@@ -162,8 +162,10 @@ main :: IO () main = execParser opts >>= compile   where-  opts        = info (helper <*> pscMakeOptions) infoModList+  opts        = info (version <*> helper <*> pscMakeOptions) infoModList   infoModList = fullDesc <> headerInfo <> footerInfo   headerInfo  = header   "psc-make - Compiles PureScript to Javascript"   footerInfo  = footer $ "psc-make " ++ showVersion Paths.version-+  +  version :: Parser (a -> a)+  version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

@@ -192,8 +192,11 @@ main :: IO () main = execParser opts >>= compile   where-  opts        = info (helper <*> pscOptions) infoModList+  opts        = info (version <*> helper <*> pscOptions) infoModList   infoModList = fullDesc <> headerInfo <> footerInfo   headerInfo  = header   "psc - Compiles PureScript to Javascript"   footerInfo  = footer $ "psc " ++ showVersion Paths.version+  +  version :: Parser (a -> a)+  version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden 

@@ -69,16 +69,19 @@ -- | -- The help menu. ---help :: [[String]]+help :: [(String, String, String)] help =-  [ [":?          ", "Show this help menu"]-  , [":i <module> ", "Import <module> for use in PSCI"]-  , [":b <module> ", "Browse <module>"]-  , [":m <file>   ", "Load <file> for importing"]-  , [":q          ", "Quit PSCi"]-  , [":r          ", "Reset"]-  , [":s import   ", "Show imported modules"]-  , [":s loaded   ", "Show loaded modules"]-  , [":t <expr>   ", "Show the type of <expr>"]-  , [":k <type>   ", "Show the kind of <type>"]+  [ (":?", "",         "Show this help menu")+  , (":i", "<module>", "Import <module> for use in PSCI")+  , (":b", "<module>", "Browse <module>")+  , (":m", "<file>",   "Load <file> for importing")+  , (":q", "",         "Quit PSCi")+  , (":r", "",         "Reset")+  , (":s", "import",   "Show imported modules")+  , (":s", "loaded",   "Show loaded modules")+  , (":t", "<expr>",   "Show the type of <expr>")+  , (":k", "<type>",   "Show the kind of <type>")   ]++commands :: [String]+commands = map (\ (a, _, _) -> a) help

@@ -22,6 +22,7 @@ import Data.Maybe (mapMaybe) import Data.Traversable (traverse) import Data.Version (showVersion)+import Data.Char (isSpace) import qualified Data.Map as M  import Control.Applicative@@ -127,7 +128,9 @@ -- Loads a file for use with imports. -- loadModule :: FilePath -> IO (Either String [P.Module])-loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename+loadModule filename = do+  content <- U.readFile filename+  return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]  -- | -- Load all modules, including the Prelude@@ -153,7 +156,9 @@ -- helpMessage :: String helpMessage = "The following commands are available:\n\n    " ++-  intercalate "\n    " (map (intercalate "    ") C.help)+  intercalate "\n    " (map line C.help)+  where line :: (String, String, String) -> String+        line (cmd, arg, desc) = intercalate " " [cmd, arg, replicate (11 - length arg) ' ', desc]  -- | -- The welcome prologue.@@ -180,37 +185,120 @@  -- Haskeline completions +data CompletionContext = Command String | FilePath String | Module | Identifier+                       | Type | Fixed [String] | Multiple [CompletionContext]+                         deriving (Show)+ -- |+-- Decide what kind of completion we need based on input.+completionContext :: String -> String -> Maybe CompletionContext+completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]+completionContext cmd@(':' : _ ) _+  | cmd `elem` C.commands || cmd == ":" = Just $ Command cmd+completionContext (':' : c : _) word = case c of+  'i' -> Just Module+  'b' -> Just Module+  'm' -> Just $ FilePath word+  'q' -> Nothing+  'r' -> Nothing+  '?' -> Nothing+  's' -> Just $ Fixed ["import", "loaded"]+  't' -> Just Identifier+  'k' -> Just Type+  _   -> Nothing+completionContext _ _ = Just Identifier++-- | -- Loads module, function, and file completions. -- completion :: CompletionFunc (StateT PSCiState IO)-completion = completeWord Nothing " \t\n\r" findCompletions+completion = completeWordWithPrev Nothing " \t\n\r" findCompletions   where-  findCompletions :: String -> StateT PSCiState IO [Completion]-  findCompletions st = do-    ms <- map snd . psciLoadedModules <$> get-    files <- listFiles st-    let matches = filter (isPrefixOf st) (names ms)-    return $ sortBy sorter $ map simpleCompletion matches ++ files-  getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident-  getDeclName Nothing (P.ValueDeclaration ident _ _ _) = Just ident-  getDeclName (Just exts) (P.ValueDeclaration ident _ _ _) | isExported = Just ident-    where-    isExported = any exports exts-    exports (P.ValueRef ident') = ident == ident'-    exports (P.PositionedDeclarationRef _ r) = exports r-    exports _ = False-  getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d-  getDeclName _ _ = Nothing-  names :: [P.Module] -> [String]-  names ms = nub [ show qual-              | P.Module moduleName ds exts <- ms-              , ident <- mapMaybe (getDeclName exts) ds-              , qual <- [ P.Qualified Nothing ident-                        , P.Qualified (Just moduleName) ident]-              ]+  findCompletions :: String -> String -> StateT PSCiState IO [Completion]+  findCompletions prev word = do+    let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word+    completions <- case ctx of+      Nothing -> return []+      (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand+                                               then Just $ simpleCompletion cand+                                               else Nothing) Just)+                  <$> getCompletion c+    return $ sortBy sorter completions++  getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]+  getCompletion (Command s) = return $ (map Left) $ nub $ filter (isPrefixOf s) C.commands+  getCompletion (FilePath f) = (map Right) <$> listFiles f+  getCompletion Module = (map Left) <$> getModuleNames+  getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames)+  getCompletion Type = (map Left) <$> getTypeNames+  getCompletion (Fixed list) = return $ (map Left) list+  getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts++  getLoadedModules :: StateT PSCiState IO [P.Module]+  getLoadedModules = map snd . psciLoadedModules <$> get++  getModuleNames :: StateT PSCiState IO [String]+  getModuleNames = moduleNames <$> getLoadedModules++  mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String]+  mapLoadedModulesAndQualify f = do+    ms <- getLoadedModules+    q <- sequence [qualifyIfNeeded m (f m) | m <- ms]+    return $ concat q++  getIdentNames :: StateT PSCiState IO [String]+  getIdentNames = mapLoadedModulesAndQualify identNames++  getDctorNames :: StateT PSCiState IO [String]+  getDctorNames = mapLoadedModulesAndQualify dctorNames++  getTypeNames :: StateT PSCiState IO [String]+  getTypeNames = mapLoadedModulesAndQualify typeDecls++  qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String]+  qualifyIfNeeded m decls = do+    let name = P.getModuleName m+    imported <- psciImportedModuleNames <$> get+    let qualified = map (P.Qualified $ Just name) decls+    if name `elem` imported then+        return $ map show $ qualified ++ (map (P.Qualified Nothing) decls)+    else+        return $ map show qualified++  typeDecls :: P.Module -> [N.ProperName]+  typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m)+      where getTypeName :: P.Declaration -> Maybe N.ProperName+            getTypeName (P.TypeSynonymDeclaration name _ _) = Just name+            getTypeName (P.DataDeclaration _ name _ _) = Just name+            getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d+            getTypeName _ = Nothing++  identNames :: P.Module -> [N.Ident]+  identNames (P.Module _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]+    where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident+          getDeclName exts decl@(P.ValueDeclaration ident _ _ _)  | P.isExported exts decl = Just ident+          getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident+          getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d+          getDeclName _ _ = Nothing++  dctorNames :: P.Module -> [N.ProperName]+  dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames+    where getDataDeclName :: P.Declaration -> Maybe N.ProperName+          getDataDeclName (P.DataDeclaration _ name _ _) = Just name+          getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d+          getDataDeclName _ = Nothing++          dnames :: [N.ProperName]+          dnames = (mapMaybe getDataDeclName onlyDataDecls)++          onlyDataDecls :: [P.Declaration]+          onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))++  moduleNames :: [P.Module] -> [String]+  moduleNames ms = nub [show moduleName | P.Module moduleName _ _ <- ms]+   sorter :: Completion -> Completion -> Ordering-  sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2+  sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2  -- Compilation @@ -441,7 +529,7 @@ -- | -- Parses the input and returns either a Metacommand or an expression. ---getCommand :: Bool -> InputT (StateT PSCiState IO) (Either Par.ParseError (Maybe Command))+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) getCommand singleLineMode = do   firstLine <- getInputLine "> "   case firstLine of@@ -519,7 +607,7 @@         go = do           c <- getCommand singleLineMode           case c of-            Left err -> outputStrLn (show err) >> go+            Left err -> outputStrLn err >> go             Right Nothing -> go             Right (Just Quit) -> outputStrLn quitMessage             Right (Just c') -> runPSCI (handleCommand c') >> go@@ -541,8 +629,10 @@ main :: IO () main = execParser opts >>= loop   where-  opts        = info (helper <*> psciOptions) infoModList+  opts        = info (version <*> helper <*> psciOptions) infoModList   infoModList = fullDesc <> headerInfo <> footerInfo   headerInfo  = header   "psci - Interactive mode for PureScript"   footerInfo  = footer $ "psci " ++ showVersion Paths.version +  version :: Parser (a -> a)+  version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

@@ -17,6 +17,8 @@     parseCommand   ) where +import Prelude hiding (lex)+ import Commands  import Data.Char (isSpace)@@ -29,84 +31,52 @@ import qualified Language.PureScript.Parser.Common as C (mark, same)  -- |--- PSCI version of @let@.--- This is essentially let from do-notation.--- However, since we don't support the @Eff@ monad,--- we actually want the normal @let@.----psciLet :: Parsec String P.ParseState Command-psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C.same *> P.parseDeclaration))))---- | -- Parses PSCI metacommands or expressions input from the user. ---parseCommand :: String -> Either ParseError Command-parseCommand = P.runIndentParser "" $ choice-                    [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf <|> psciBrowse <|> psciShowModules)-                    , try psciLet-                    , psciExpression-                    ] <* eof---- |--- Parses expressions entered at the PSCI repl.----psciExpression :: Parsec String P.ParseState Command-psciExpression = Expression <$> P.parseValue---- |--- Parses 'Commands.Help' command.----psciHelp :: Parsec String P.ParseState Command-psciHelp = Help <$ char '?'---- |--- Parses 'Commands.Import' command.----psciImport :: Parsec String P.ParseState Command-psciImport = Import <$> (char 'i' *> P.whiteSpace *> P.moduleName)---- |--- Parses 'Commands.LoadFile' command.----psciLoadFile :: Parsec String P.ParseState Command-psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof)---- | Trim end of input string-trimEnd :: String -> String-trimEnd = reverse . dropWhile isSpace . reverse---- |--- Parses 'Commands.Quit' command.----psciQuit :: Parsec String P.ParseState Command-psciQuit = Quit <$ char 'q'---- |--- Parses 'Commands.Reload' command.----psciReload :: Parsec String P.ParseState Command-psciReload = Reset <$ char 'r'---- |--- Parses 'Commands.TypeOf' command.----psciTypeOf :: Parsec String P.ParseState Command-psciTypeOf = TypeOf <$> (char 't' *> P.whiteSpace *> P.parseValue)----- |--- Parses 'Commands.KindOf' command.----psciKindOf :: Parsec String P.ParseState Command-psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType)+parseCommand :: String -> Either String Command+parseCommand cmdString = +  case splitCommand cmdString of +    Just ('?', _) -> return Help+    Just ('q', _) -> return Quit+    Just ('r', _) -> return Reset+    Just ('i', moduleName) -> Import <$> parseRest P.moduleName moduleName+    Just ('b', moduleName) -> Browse <$> parseRest P.moduleName moduleName+    Just ('m', filename) -> return $ LoadFile (trimEnd filename)+    Just ('s', command) -> return $ Show (trimEnd command)+    Just ('t', expr) -> TypeOf <$> parseRest P.parseValue expr+    Just ('k', ty) -> KindOf <$> parseRest P.parseType ty+    Just _ -> Left $ "Unrecognized command. Type :? for help."+    Nothing -> parseRest (psciLet <|> psciExpression) cmdString+  where+  parseRest :: P.TokenParser a -> String -> Either String a+  parseRest p s = either (Left . show) Right $ do+    ts <- P.lex "" s+    P.runTokenParser "" (p <* eof) ts+  +  trimEnd :: String -> String+  trimEnd = reverse . dropWhile isSpace . reverse --- |--- Parses 'Commands.Browse' command.----psciBrowse :: Parsec String P.ParseState Command-psciBrowse = Browse <$> (char 'b' *> P.whiteSpace *> P.moduleName)+  -- |+  -- Split a command into a command char and the trailing string+  --+  splitCommand :: String -> Maybe (Char, String)+  splitCommand (':' : c : s) = Just (c, dropWhile isSpace s)+  splitCommand _ = Nothing --- |--- Show Command-psciShowModules :: Parsec String P.ParseState Command-psciShowModules = Show . trimEnd <$> (char 's' *> P.whiteSpace *> manyTill anyChar eof)+  -- |+  -- Parses expressions entered at the PSCI repl.+  --+  psciExpression :: P.TokenParser Command+  psciExpression = Expression <$> P.parseValue+  +  -- |+  -- PSCI version of @let@.+  -- This is essentially let from do-notation.+  -- However, since we don't support the @Eff@ monad,+  -- we actually want the normal @let@.+  --+  psciLet :: P.TokenParser Command+  psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> manyDecls))+    where+    manyDecls :: P.TokenParser [P.Declaration]+    manyDecls = C.mark (many1 (C.same *> P.parseDeclaration))

@@ -1,5 +1,5 @@ name: purescript-version: 0.6.2+version: 0.6.3 cabal-version: >=1.8 build-type: Simple license: MIT@@ -45,26 +45,37 @@                      Language.PureScript.AST.SourcePos                      Language.PureScript.AST.Traversals                      Language.PureScript.CodeGen-                     Language.PureScript.CodeGen.Common                      Language.PureScript.CodeGen.Externs                      Language.PureScript.CodeGen.JS                      Language.PureScript.CodeGen.JS.AST+                     Language.PureScript.CodeGen.JS.Common+                     Language.PureScript.CodeGen.JS.Optimizer+                     Language.PureScript.CodeGen.JS.Optimizer.Blocks+                     Language.PureScript.CodeGen.JS.Optimizer.Common+                     Language.PureScript.CodeGen.JS.Optimizer.Inliner+                     Language.PureScript.CodeGen.JS.Optimizer.MagicDo+                     Language.PureScript.CodeGen.JS.Optimizer.TCO+                     Language.PureScript.CodeGen.JS.Optimizer.Unused                      Language.PureScript.Constants+                     Language.PureScript.CoreFn+                     Language.PureScript.CoreFn.Ann+                     Language.PureScript.CoreFn.Binders+                     Language.PureScript.CoreFn.Desugar+                     Language.PureScript.CoreFn.Expr+                     Language.PureScript.CoreFn.Literals+                     Language.PureScript.CoreFn.Meta+                     Language.PureScript.CoreFn.Module+                     Language.PureScript.CoreFn.Traversals+                     Language.PureScript.Comments                      Language.PureScript.DeadCodeElimination                      Language.PureScript.Environment                      Language.PureScript.Errors                      Language.PureScript.Kinds                      Language.PureScript.ModuleDependencies                      Language.PureScript.Names-                     Language.PureScript.Optimizer-                     Language.PureScript.Optimizer.Blocks-                     Language.PureScript.Optimizer.Common-                     Language.PureScript.Optimizer.Inliner-                     Language.PureScript.Optimizer.MagicDo-                     Language.PureScript.Optimizer.TCO-                     Language.PureScript.Optimizer.Unused                      Language.PureScript.Options                      Language.PureScript.Parser+                     Language.PureScript.Parser.Lexer                      Language.PureScript.Parser.Common                      Language.PureScript.Parser.Declarations                      Language.PureScript.Parser.Kinds@@ -103,58 +114,58 @@     buildable: True     hs-source-dirs: src     other-modules: Paths_purescript-    ghc-options: -Wall -O2+    ghc-options: -Wall -fno-warn-warnings-deprecations -O2  executable psc-    build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, -                   mtl -any, optparse-applicative -any, parsec -any, purescript -any,+    build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,+                   mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,                    transformers -any, utf8-string -any     main-is: Main.hs     buildable: True     hs-source-dirs: psc     other-modules:-    ghc-options: -Wall -O2 -fno-warn-unused-do-bind+    ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind  executable psc-make-    build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, -                   mtl -any, optparse-applicative -any, parsec -any, purescript -any, +    build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,+                   mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,                    transformers -any, utf8-string -any     main-is: Main.hs     buildable: True     hs-source-dirs: psc-make     other-modules:-    ghc-options: -Wall -O2 -fno-warn-unused-do-bind+    ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind  executable psci     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,-                   mtl -any, optparse-applicative -any, parsec -any, -                   haskeline >= 0.7.0.0, purescript -any, transformers -any, +                   mtl -any, optparse-applicative >= 0.10.0, parsec -any,+                   haskeline >= 0.7.0.0, purescript -any, transformers -any,                    utf8-string -any, process -any-                   +     main-is: Main.hs     buildable: True     hs-source-dirs: psci     other-modules: Commands                    Parser-    ghc-options: -Wall -O2+    ghc-options: -Wall -fno-warn-warnings-deprecations -O2  executable psc-docs     build-depends: base >=4 && <5, purescript -any, utf8-string -any,-                   optparse-applicative -any, process -any, mtl -any+                   optparse-applicative >= 0.10.0, process -any, mtl -any     main-is: Main.hs     buildable: True     hs-source-dirs: psc-docs     other-modules:-    ghc-options: -Wall -O2+    ghc-options: -Wall -fno-warn-warnings-deprecations -O2  executable hierarchy-    build-depends: base >=4 && <5, purescript -any, utf8-string -any, optparse-applicative -any,+    build-depends: base >=4 && <5, purescript -any, utf8-string -any, optparse-applicative >= 0.10.0,                    process -any, mtl -any, parsec -any, filepath -any, directory -any     main-is: Main.hs     buildable: True     hs-source-dirs: hierarchy     other-modules:-    ghc-options: -Wall -O2+    ghc-options: -Wall -fno-warn-warnings-deprecations -O2  test-suite tests     build-depends: base >=4 && <5, containers -any, directory -any,

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript--- Copyright   :  (c) Phil Freeman 2013+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors -- License     :  MIT -- -- Maintainer  :  Phil Freeman <paf31@cantab.net>@@ -17,42 +17,41 @@  module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where -import Language.PureScript.Types as P-import Language.PureScript.Kinds as P+import Data.FileEmbed (embedFile)+import Data.Function (on)+import Data.List (sortBy, groupBy, intercalate)+import Data.Maybe (fromMaybe)+import Data.Time.Clock+import qualified Data.ByteString.UTF8 as BU+import qualified Data.Map as M+import qualified Data.Set as S++import Control.Applicative+import Control.Arrow ((&&&))+import Control.Monad.Error++import System.FilePath ((</>))+ import Language.PureScript.AST as P+import Language.PureScript.Comments as P+import Language.PureScript.CodeGen as P+import Language.PureScript.DeadCodeElimination as P+import Language.PureScript.Environment as P+import Language.PureScript.Errors as P+import Language.PureScript.Kinds as P+import Language.PureScript.ModuleDependencies as P import Language.PureScript.Names as P+import Language.PureScript.Options as P import Language.PureScript.Parser as P-import Language.PureScript.CodeGen as P-import Language.PureScript.CodeGen.Common as P-import Language.PureScript.TypeChecker as P import Language.PureScript.Pretty as P+import Language.PureScript.Renamer as P import Language.PureScript.Sugar as P-import Language.PureScript.Options as P-import Language.PureScript.ModuleDependencies as P-import Language.PureScript.Environment as P-import Language.PureScript.Errors as P-import Language.PureScript.DeadCodeElimination as P import Language.PureScript.Supply as P-import Language.PureScript.Renamer as P-+import Language.PureScript.TypeChecker as P+import Language.PureScript.Types as P+import qualified Language.PureScript.CoreFn as CoreFn import qualified Language.PureScript.Constants as C -import Data.List (sortBy, groupBy, intercalate)-import Data.Time.Clock-import Data.Function (on)-import Data.Maybe (fromMaybe)-import Data.FileEmbed (embedFile)--import Control.Monad.Error-import Control.Arrow ((&&&))-import Control.Applicative--import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.ByteString.UTF8 as BU--import System.FilePath ((</>))- -- | -- Compile a collection of modules --@@ -77,17 +76,18 @@  compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment) compile' env opts ms prefix = do-  (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms)+  (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms   (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted   (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent   regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated+  let corefn = map (CoreFn.moduleToCoreFn env') regrouped   let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)-  let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped+  let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn   let renamed = renameInModules elim   let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)-  let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModuleNames) renamed-  let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs opts m env') modulesToCodeGen-  let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen+  let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed+  let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen+  let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped   js' <- generateMain env' opts js   let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']   return (pjs, exts, env')@@ -156,7 +156,7 @@ make outputDir opts ms prefix = do   let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) -  (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)+  (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms    toRebuild <- foldM (\s (Module moduleName' _ _) -> do     let filePath = runModuleName moduleName'@@ -199,11 +199,12 @@     regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module moduleName' regrouped exps-    let [renamed] = renameInModules [mod']+    let corefn = CoreFn.moduleToCoreFn env' mod'+    let [renamed] = renameInModules [corefn] -    pjs <- prettyPrintJS <$> moduleToJs opts renamed env'+    pjs <- prettyPrintJS <$> moduleToJs opts renamed     let js = unlines $ map ("// " ++) prefix ++ [pjs]-    let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env']+    let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']      lift $ writeTextFile jsFile js     lift $ writeTextFile externsFile exts@@ -219,7 +220,7 @@   rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do     let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"     externs <- readTextFile externsFile-    externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs+    externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ P.parseModulesFromFiles id [(externsFile, externs)]     case externsModules of       [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'       _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"@@ -239,7 +240,7 @@   else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps   where   isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True-  isExistingImport (PositionedDeclaration _ d) = isExistingImport d+  isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d   isExistingImport _ = False  importPrim :: Module -> Module

@@ -20,6 +20,7 @@  import Language.PureScript.AST.SourcePos import Language.PureScript.Names+import Language.PureScript.Comments  -- | -- Data type for binders@@ -68,7 +69,7 @@   -- |   -- A binder with source position information   ---  | PositionedBinder SourceSpan Binder deriving (Show, D.Data, D.Typeable)+  | PositionedBinder SourceSpan [Comment] Binder deriving (Show, D.Data, D.Typeable)  -- | -- Collect all names introduced in binders in an expression@@ -82,5 +83,5 @@   go ns (ArrayBinder bs) = foldl go ns bs   go ns (ConsBinder b1 b2) = go (go ns b1) b2   go ns (NamedBinder name b) = go (name : ns) b-  go ns (PositionedBinder _ b) = go ns b+  go ns (PositionedBinder _ _ b) = go ns b   go ns _ = ns

@@ -25,6 +25,7 @@ import Language.PureScript.Names import Language.PureScript.Kinds import Language.PureScript.TypeClassDictionaries+import Language.PureScript.Comments import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Environment @@ -34,7 +35,58 @@ -- data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable) +-- | Return a module's name.+getModuleName :: Module -> ModuleName+getModuleName (Module name _ _) = name+ -- |+-- Test if a declaration is exported, given a module's export list.+--+isExported :: Maybe [DeclarationRef] -> Declaration -> Bool+isExported Nothing _ = True+isExported _ TypeInstanceDeclaration{} = True+isExported exps (PositionedDeclaration _ _ d) = isExported exps d+isExported (Just exps) decl = any (matches decl) exps+  where+  matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'+  matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'+  matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'+  matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'+  matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'+  matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'+  matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'+  matches (PositionedDeclaration _ _ d) r = d `matches` r+  matches d (PositionedDeclarationRef _ _ r) = d `matches` r+  matches _ _ = False++exportedDeclarations :: Module -> [Declaration]+exportedDeclarations (Module _ decls exps) = filter (isExported exps) (flattenDecls decls)++-- |+-- Test if a data constructor for a given type is exported, given a module's export list.+--+isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool+isDctorExported _ Nothing _ = True+isDctorExported ident (Just exps) ctor = test `any` exps+  where+  test (PositionedDeclarationRef _ _ d) = test d+  test (TypeRef ident' Nothing) = ident == ident'+  test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors+  test _ = False++-- |+-- Return the exported data constructors for a given type.+--+exportedDctors :: Module -> ProperName -> [ProperName]+exportedDctors (Module _ decls exps) ident =+  filter (isDctorExported ident exps) dctors+  where+  dctors = concatMap getDctors (flattenDecls decls)+  getDctors (DataDeclaration _ _ _ ctors) = map fst ctors+  getDctors (PositionedDeclaration _ _ d) = getDctors d+  getDctors _ = []++-- | -- An item in a list of explicit imports or exports -- data DeclarationRef@@ -57,7 +109,7 @@   -- |   -- A declaration reference with source position information   ---  | PositionedDeclarationRef SourceSpan DeclarationRef+  | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef   deriving (Show, D.Data, D.Typeable)  instance Eq DeclarationRef where@@ -65,8 +117,8 @@   (ValueRef name)        == (ValueRef name')        = name == name'   (TypeClassRef name)    == (TypeClassRef name')    = name == name'   (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'-  (PositionedDeclarationRef _ r) == r' = r == r'-  r == (PositionedDeclarationRef _ r') = r == r'+  (PositionedDeclarationRef _ _ r) == r' = r == r'+  r == (PositionedDeclarationRef _ _ r') = r == r'   _ == _ = False  -- |@@ -126,7 +178,7 @@   -- |   -- A type class instance foreign import   ---  | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]+  | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]   -- |   -- A fixity declaration (fixity data, operator name)   --@@ -138,16 +190,16 @@   -- |   -- A type class declaration (name, argument, implies, member declarations)   ---  | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]+  | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]   -- |   -- A type instance declaration (name, dependencies, class name, instance types, member   -- declarations)   ---  | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]+  | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]   -- |   -- A declaration with source position information   ---  | PositionedDeclaration SourceSpan Declaration+  | PositionedDeclaration SourceSpan [Comment] Declaration   deriving (Show, D.Data, D.Typeable)  -- |@@ -155,7 +207,7 @@ -- isValueDecl :: Declaration -> Bool isValueDecl ValueDeclaration{} = True-isValueDecl (PositionedDeclaration _ d) = isValueDecl d+isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d isValueDecl _ = False  -- |@@ -164,7 +216,7 @@ isDataDecl :: Declaration -> Bool isDataDecl DataDeclaration{} = True isDataDecl TypeSynonymDeclaration{} = True-isDataDecl (PositionedDeclaration _ d) = isDataDecl d+isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d isDataDecl _ = False  -- |@@ -172,7 +224,7 @@ -- isImportDecl :: Declaration -> Bool isImportDecl ImportDeclaration{} = True-isImportDecl (PositionedDeclaration _ d) = isImportDecl d+isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d isImportDecl _ = False  -- |@@ -180,7 +232,7 @@ -- isExternDataDecl :: Declaration -> Bool isExternDataDecl ExternDataDeclaration{} = True-isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d+isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d isExternDataDecl _ = False  -- |@@ -188,7 +240,7 @@ -- isExternInstanceDecl :: Declaration -> Bool isExternInstanceDecl ExternInstanceDeclaration{} = True-isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d+isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d isExternInstanceDecl _ = False  -- |@@ -196,7 +248,7 @@ -- isFixityDecl :: Declaration -> Bool isFixityDecl FixityDeclaration{} = True-isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d+isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d isFixityDecl _ = False  -- |@@ -204,7 +256,7 @@ -- isExternDecl :: Declaration -> Bool isExternDecl ExternDeclaration{} = True-isExternDecl (PositionedDeclaration _ d) = isExternDecl d+isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d isExternDecl _ = False  -- |@@ -213,10 +265,18 @@ isTypeClassDeclaration :: Declaration -> Bool isTypeClassDeclaration TypeClassDeclaration{} = True isTypeClassDeclaration TypeInstanceDeclaration{} = True-isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d+isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d isTypeClassDeclaration _ = False  -- |+-- Recursively flatten data binding groups in the list of declarations+flattenDecls :: [Declaration] -> [Declaration]+flattenDecls = concatMap flattenOne+    where flattenOne :: Declaration -> [Declaration]+          flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls+          flattenOne d = [d]++-- | -- A guard is just a boolean-valued expression that appears alongside a set of binders -- type Guard = Expr@@ -316,7 +376,7 @@   -- at superclass implementations when searching for a dictionary, the type class name and   -- instance type, and the type class dictionaries in scope.   ---  | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]+  | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]   -- |   -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking   --@@ -324,7 +384,7 @@   -- |   -- A value with source position information   ---  | PositionedValue SourceSpan Expr deriving (Show, D.Data, D.Typeable)+  | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)  -- | -- An alternative in a case statement@@ -359,4 +419,4 @@   -- |   -- A do notation element with source position information   ---  | PositionedDoNotationElement SourceSpan DoNotationElement deriving (Show, D.Data, D.Typeable)+  | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable)

@@ -37,7 +37,7 @@   f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))   f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))   f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))-  f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))+  f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))   f' other = f other    g' :: Expr -> Expr@@ -56,7 +56,7 @@   g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)   g' (Let ds v) = g (Let (map f' ds) (g' v))   g' (Do es) = g (Do (map handleDoNotationElement es))-  g' (PositionedValue pos v) = g (PositionedValue pos (g' v))+  g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v))   g' other = g other    h' :: Binder -> Binder@@ -65,7 +65,7 @@   h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))   h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))   h' (NamedBinder name b) = h (NamedBinder name (h' b))-  h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))+  h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))   h' other = h other    handleCaseAlternative :: CaseAlternative -> CaseAlternative@@ -78,7 +78,7 @@   handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)   handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)   handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)-  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)+  handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)   everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>@@ -93,7 +93,7 @@   f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds   f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds   f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds-  f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')+  f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')   f' other = f other    g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')@@ -111,7 +111,7 @@   g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty   g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')   g' (Do es) = Do <$> mapM handleDoNotationElement es-  g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')+  g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')   g' other = g other    h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs@@ -119,7 +119,7 @@   h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs   h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')   h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')-  h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')+  h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')   h' other = h other    handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs@@ -128,7 +128,7 @@   handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v   handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v   handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds-  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e+  handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e  everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>   (Declaration -> m Declaration) ->@@ -142,7 +142,7 @@   f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f   f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f   f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f-  f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f+  f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f   f' other = f other    g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g@@ -160,7 +160,7 @@   g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g   g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g   g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g-  g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g+  g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g   g' other = g other    h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h@@ -168,7 +168,7 @@   h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h   h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h   h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h-  h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h+  h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h   h' other = h other    handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs@@ -177,7 +177,7 @@   handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v   handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v   handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds-  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e+  handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e  everythingOnValues :: (r -> r -> r) ->                       (Declaration -> r) ->@@ -194,7 +194,7 @@   f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)   f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)   f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)-  f' d@(PositionedDeclaration _ d1) = f d <> f' d1+  f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1   f' d = f d    g' v@(UnaryMinus v1) = g v <> g' v1@@ -212,7 +212,7 @@   g' v@(TypedValue _ v1 _) = g v <> g' v1   g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1   g' v@(Do es) = foldl (<>) (g v) (map j' es)-  g' v@(PositionedValue _ v1) = g v <> g' v1+  g' v@(PositionedValue _ _ v1) = g v <> g' v1   g' v = g v    h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)@@ -220,7 +220,7 @@   h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)   h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2   h' b@(NamedBinder _ b1) = h b <> h' b1-  h' b@(PositionedBinder _ b1) = h b <> h' b1+  h' b@(PositionedBinder _ _ b1) = h b <> h' b1   h' b = h b    i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val@@ -229,7 +229,7 @@   j' e@(DoNotationValue v) = j e <> g' v   j' e@(DoNotationBind b v) = j e <> h' b <> g' v   j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)-  j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1+  j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1  everythingWithContextOnValues ::   s ->@@ -255,7 +255,7 @@   f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)   f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)   f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)-  f' s (PositionedDeclaration _ d1) = f'' s d1+  f' s (PositionedDeclaration _ _ d1) = f'' s d1   f' _ _ = r0    g'' s v = let (s', r) = g s v in r <> g' s' v@@ -275,7 +275,7 @@   g' s (TypedValue _ v1 _) = g'' s v1   g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1   g' s (Do es) = foldl (<>) r0 (map (j'' s) es)-  g' s (PositionedValue _ v1) = g'' s v1+  g' s (PositionedValue _ _ v1) = g'' s v1   g' _ _ = r0    h'' s b = let (s', r) = h s b in r <> h' s' b@@ -285,7 +285,7 @@   h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)   h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2   h' s (NamedBinder _ b1) = h'' s b1-  h' s (PositionedBinder _ b1) = h'' s b1+  h' s (PositionedBinder _ _ b1) = h'' s b1   h' _ _ = r0    i'' s ca = let (s', r) = i s ca in r <> i' s' ca@@ -298,7 +298,7 @@   j' s (DoNotationValue v) = g'' s v   j' s (DoNotationBind b v) = h'' s b <> g'' s v   j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)-  j' s (PositionedDoNotationElement _ e1) = j'' s e1+  j' s (PositionedDoNotationElement _ _ e1) = j'' s e1  everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>   s ->@@ -321,7 +321,7 @@   f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds   f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds   f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds-  f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1+  f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1   f' _ other = return other    g'' s = uncurry g' <=< g s@@ -341,7 +341,7 @@   g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty   g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v   g' s (Do es) = Do <$> mapM (j'' s) es-  g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v+  g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v   g' _ other = return other    h'' s = uncurry h' <=< h s@@ -351,7 +351,7 @@   h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs   h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2   h' s (NamedBinder name b) = NamedBinder name <$> h'' s b-  h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b+  h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b   h' _ other = return other    i'' s = uncurry i' <=< i s@@ -363,7 +363,7 @@   j' s (DoNotationValue v) = DoNotationValue <$> g'' s v   j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v   j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds-  j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1+  j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1  accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

@@ -1,193 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.Common--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Common code generation utility functions-----------------------------------------------------------------------------------module Language.PureScript.CodeGen.Common where--import Data.Char-import Data.List (intercalate)-import Data.Maybe (fromMaybe)-import Data.Function (on)--import qualified Data.Map as M--import Language.PureScript.Names-import Language.PureScript.Environment-import Language.PureScript.Types---- |--- Convert an Ident into a valid Javascript identifier:------  * Alphanumeric characters are kept unmodified.------  * Reserved javascript identifiers are prefixed with '$$'.------  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.----identToJs :: Ident -> String-identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name-identToJs (Ident name) = concatMap identCharToString name-identToJs (Op op) = concatMap identCharToString op---- |--- Test if a string is a valid JS identifier without escaping.----identNeedsEscaping :: String -> Bool-identNeedsEscaping s = s /= identToJs (Ident s)---- |--- Attempts to find a human-readable name for a symbol, if none has been specified returns the--- ordinal value.----identCharToString :: Char -> String-identCharToString c | isAlphaNum c = [c]-identCharToString '_' = "_"-identCharToString '.' = "$dot"-identCharToString '$' = "$dollar"-identCharToString '~' = "$tilde"-identCharToString '=' = "$eq"-identCharToString '<' = "$less"-identCharToString '>' = "$greater"-identCharToString '!' = "$bang"-identCharToString '#' = "$hash"-identCharToString '%' = "$percent"-identCharToString '^' = "$up"-identCharToString '&' = "$amp"-identCharToString '|' = "$bar"-identCharToString '*' = "$times"-identCharToString '/' = "$div"-identCharToString '+' = "$plus"-identCharToString '-' = "$minus"-identCharToString ':' = "$colon"-identCharToString '\\' = "$bslash"-identCharToString '?' = "$qmark"-identCharToString '@' = "$at"-identCharToString '\'' = "$prime"-identCharToString c = '$' : show (ord c)---- |--- Checks whether an identifier name is reserved in Javascript.----nameIsJsReserved :: String -> Bool-nameIsJsReserved name =-  name `elem` [ "abstract"-              , "arguments"-              , "boolean"-              , "break"-              , "byte"-              , "case"-              , "catch"-              , "char"-              , "class"-              , "const"-              , "continue"-              , "debugger"-              , "default"-              , "delete"-              , "do"-              , "double"-              , "else"-              , "enum"-              , "eval"-              , "export"-              , "extends"-              , "final"-              , "finally"-              , "float"-              , "for"-              , "function"-              , "goto"-              , "if"-              , "implements"-              , "import"-              , "in"-              , "instanceof"-              , "int"-              , "interface"-              , "let"-              , "long"-              , "native"-              , "new"-              , "null"-              , "package"-              , "private"-              , "protected"-              , "public"-              , "return"-              , "short"-              , "static"-              , "super"-              , "switch"-              , "synchronized"-              , "this"-              , "throw"-              , "throws"-              , "transient"-              , "try"-              , "typeof"-              , "var"-              , "void"-              , "volatile"-              , "while"-              , "with"-              , "yield" ]--moduleNameToJs :: ModuleName -> String-moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)---- |--- Finds the value stored for a data constructor in the current environment.--- This is a partial function, but if an invalid type has reached this far then--- something has gone wrong in typechecking.----lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)-lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e---- |--- Checks whether a data constructor is the only constructor for that type, used--- to simplify the check when generating code for binders.----isOnlyConstructor :: Environment -> Qualified ProperName -> Bool-isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1-  where-  numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int-  numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e-  typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)-  typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)-  typeConstructor _ = error "Invalid argument to isOnlyConstructor"---- |--- Checks whether a data constructor is for a newtype.----isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool-isNewtypeConstructor e ctor = case lookupConstructor e ctor of-  (Newtype, _, _) -> True-  (Data, _, _) -> False---- |--- Checks the number of arguments a data constructor accepts.----getConstructorArity :: Environment -> Qualified ProperName -> Int-getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e-  where-  go :: Type -> Int-  go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1-  go (ForAll _ ty _) = go ty-  go _ = 0---- |--- Checks whether a data constructor has no arguments, for example, `Nothing`.----isNullaryConstructor :: Environment -> Qualified ProperName -> Bool-isNullaryConstructor e = (== 0) . getConstructorArity e

@@ -17,21 +17,20 @@     moduleToPs ) where -import Data.Maybe (fromMaybe, mapMaybe) import Data.List (intercalate, find)-+import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M  import Control.Monad.Writer -import Language.PureScript.CodeGen.Common-import Language.PureScript.TypeClassDictionaries import Language.PureScript.AST-import Language.PureScript.Pretty-import Language.PureScript.Names+import Language.PureScript.Environment import Language.PureScript.Kinds+import Language.PureScript.Names+import Language.PureScript.Pretty+import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types-import Language.PureScript.Environment+import Language.PureScript.Comments  -- | -- Generate foreign imports for all declarations in a module@@ -48,11 +47,15 @@     declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]     declToPs (FixityDeclaration (Fixity assoc prec) ident) =       tell [ unwords [ show assoc, show prec, ident ] ]-    declToPs (PositionedDeclaration _ d) = declToPs d+    declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d     declToPs _ = return ()+    +    commentToPs :: Comment -> Writer [String] ()+    commentToPs (LineComment s) = tell ["-- " ++ s]+    commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]      exportToPs :: DeclarationRef -> Writer [String] ()-    exportToPs (PositionedDeclarationRef _ r) = exportToPs r+    exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r     exportToPs (TypeRef pn dctors) = do       case Qualified (Just moduleName) pn `M.lookup` types env of         Nothing -> error $ show pn ++ " has no kind in exportToPs"@@ -109,4 +112,3 @@      isValueExported :: Ident -> Bool     isValueExported ident = ValueRef ident `elem` exts-

@@ -13,32 +13,28 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs, DoAndIfThenElse #-}+{-# LANGUAGE GADTs, ViewPatterns #-}  module Language.PureScript.CodeGen.JS (     module AST,-    declToJs,-    moduleToJs,-    identNeedsEscaping+    module Common,+    bindToJs,+    moduleToJs ) where -import Data.Maybe (catMaybes)-import Data.Function (on)-import Data.List (nub, (\\), delete, sortBy)--import qualified Data.Map as M+import Data.List ((\\), delete)+import Data.Maybe (mapMaybe) -import Control.Monad (foldM, replicateM, forM) import Control.Applicative-import Control.Arrow (second)+import Control.Arrow ((&&&))+import Control.Monad (foldM, replicateM, forM) +import Language.PureScript.CodeGen.JS.AST as AST+import Language.PureScript.CodeGen.JS.Common as Common+import Language.PureScript.CoreFn import Language.PureScript.Names-import Language.PureScript.AST+import Language.PureScript.CodeGen.JS.Optimizer import Language.PureScript.Options-import Language.PureScript.CodeGen.JS.AST as AST-import Language.PureScript.Optimizer-import Language.PureScript.CodeGen.Common-import Language.PureScript.Environment import Language.PureScript.Supply import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants as C@@ -47,25 +43,28 @@ -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. ---moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module -> Environment -> SupplyT m [JS]-moduleToJs opts (Module name decls (Just exps)) env = do-  let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls-  jsDecls <- mapM (\decl -> declToJs opts name decl env) decls-  let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls+moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]+moduleToJs opts (Module name imps exps foreigns decls) = do+  let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps+  let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns+  jsDecls <- mapM (bindToJs name) decls+  let optimized = concatMap (map $ optimize opts) jsDecls   let isModuleEmpty = null exps-  let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized-  let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps+  let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized+  let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps   return $ case optionsAdditional opts of-    MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]+    MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']     CompileOptions ns _ _ | not isModuleEmpty ->       [ JSVariableIntroduction ns                                (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )       , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))-                     (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])+                     (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])       ]     _ -> []-moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring" +-- |+-- Generates Javascript code for a module import.+-- importToJs :: Options mode -> ModuleName -> JS importToJs opts mn =   JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)@@ -74,95 +73,26 @@     MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]     CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns) -imports :: Declaration -> [ModuleName]-imports (ImportDeclaration mn _ _) = [mn]-imports other =-  let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])-  in f other-  where-  collectV :: Expr -> [ModuleName]-  collectV (Var (Qualified (Just mn) _)) = [mn]-  collectV (Constructor (Qualified (Just mn) _)) = [mn]-  collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]-  collectV _ = []-  collectB :: Binder -> [ModuleName]-  collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]-  collectB _ = []- -- | -- Generate code in the simplified Javascript intermediate representation for a declaration ---declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])-declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do-  js <- valueToJs opts mp e val-  return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]-declToJs opts mp (BindingGroupDeclaration vals) e = do-  jss <- forM vals $ \(ident, _, val) -> do-    js <- valueToJs opts mp e val-    return $ JSVariableIntroduction (identToJs ident) (Just js)-  return $ Just jss-declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =-  return $ Just $ [JSVariableIntroduction ctor (Just $-                    JSObjectLiteral [("create",-                      JSFunction Nothing ["value"]-                        (JSBlock [JSReturn $ JSVar "value"]))])]-declToJs _ _ (DataDeclaration Newtype _ _ _) _ =-  error "newtype has multiple constructors"-declToJs _ mp (DataDeclaration Data _ _ ctors) e = do-  return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->-      let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"-      in [ makeConstructor ctor (length tys)-         , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])-         ]-    where-    makeConstructor :: String -> Int -> JS-    makeConstructor ctorName n =-      let-        args = [ "value" ++ show index | index <- [0..n-1] ]-        body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]-      in JSFunction (Just ctorName) args (JSBlock body)-    go :: ProperName -> Int -> Int -> [JS] -> JS-    go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar $ runProperName pn) (reverse values)-    go pn index n values =-      JSFunction Nothing ["value" ++ show index]-        (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])-declToJs opts mp (DataBindingGroupDeclaration ds) e = do-  jss <- mapM (\decl -> declToJs opts mp decl e) ds-  return $ Just $ concat $ catMaybes jss-declToJs _ _ (TypeClassDeclaration name _ supers members) _ =-  return $ Just $ [-    JSFunction (Just $ runProperName name) (identToJs `map` args)-      (JSBlock $ assn `map` args)]-  where-  assn :: Ident -> JS-  assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)-  args :: [Ident]-  args = sortBy (compare `on` runIdent) $ memberNames ++ superNames-  memberNames :: [Ident]-  memberNames = memberToName `map` members-  superNames :: [Ident]-  superNames = [ toSuperName superclass index-               | (index, (superclass, _)) <- zip [0..] supers-               ]-  toSuperName :: Qualified ProperName -> Integer -> Ident-  toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index-  memberToName :: Declaration -> Ident-  memberToName (TypeDeclaration ident _) = ident-  memberToName (PositionedDeclaration _ d) = memberToName d-  memberToName _ = error "Invalid declaration in type class definition"-declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]-declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e-declToJs _ _ _ _ = return Nothing+bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m [JS]+bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val+bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))  -- |--- Generate key//value pairs for an object literal exporting values from a module.+-- Generate code in the simplified Javascript intermediate representation for a single non-recursive +-- declaration. ---exportToJs :: DeclarationRef -> M.Map String Ident-exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ]-exportToJs (ValueRef name)           = M.singleton (runIdent name) name-exportToJs (TypeInstanceRef name)    = M.singleton (runIdent name) name-exportToJs (TypeClassRef name)       = M.singleton (runProperName name) (Ident $ runProperName name)-exportToJs _                         = M.empty+-- The main purpose of this function is to handle code generation for comments.+--+nonRecToJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Ident -> Expr Ann -> SupplyT m JS+nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) =+  JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)+nonRecToJS mp ident val = do+  js <- valueToJs mp val+  return $ JSVariableIntroduction (identToJs ident) (Just js)+    -- | -- Generate code in the simplified Javascript intermediate representation for a variable based on a@@ -187,55 +117,90 @@ -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. ---valueToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS-valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n-valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s-valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b-valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs-valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps-valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =-  JSUnary JSNew . JSApp (qualifiedToJS m (Ident . runProperName) name) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)-valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =-  error "TypeClassDictionaryConstructorApp did not contain object literal"-valueToJs opts m e (ObjectUpdate o ps) = do-  obj <- valueToJs opts m e o-  sts <- mapM (sndM (valueToJs opts m e)) ps+valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS+valueToJs m (Literal _ l) =+  literalToValueJS m l+valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =+  return $ JSAccessor "value" $ qualifiedToJS m id name+valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =+  return $ JSAccessor "create" $ qualifiedToJS m id name+valueToJs m (Accessor _ prop val) =+  accessorString prop <$> valueToJs m val+valueToJs m (ObjectUpdate _ o ps) = do+  obj <- valueToJs m o+  sts <- mapM (sndM (valueToJs m)) ps   extendObj obj sts-valueToJs _ m e (Constructor name) =-  let propName = if isNullaryConstructor e name then "value" else "create"-  in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name-valueToJs opts m e (Case values binders) = do-  vals <- mapM (valueToJs opts m e) values-  bindersToJs opts m e binders vals-valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el-valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val-valueToJs opts m e v@App{} = do-  let (f, args) = unApp v []-  args' <- mapM (valueToJs opts m e) args+valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =+  let args = unAbs e+  in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)+  where+  unAbs :: Expr Ann -> [Ident]+  unAbs (Abs _ arg val) = arg : unAbs val+  unAbs _ = []+  assign :: Ident -> JS+  assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))+                             (var name)+valueToJs m (Abs _ arg val) = do+  ret <- valueToJs m val+  return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])+valueToJs m e@App{} = do+  let (f, args) = unApp e []+  args' <- mapM (valueToJs m) args   case f of-    Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')-    Constructor name | getConstructorArity e name == length args ->-      return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'-    _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f+    Var (_, _, _, Just IsNewtype) _ -> return (head args')+    Var (_, _, _, Just (IsConstructor _ arity)) name | arity == length args ->+      return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'+    Var (_, _, _, Just IsTypeClassConstructor) name ->+      return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'+    _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f   where-  unApp :: Expr -> [Expr] -> (Expr, [Expr])-  unApp (App val arg) args = unApp val (arg : args)-  unApp (PositionedValue _ val) args = unApp val args-  unApp (TypedValue _ val _) args = unApp val args+  unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])+  unApp (App _ val arg) args = unApp val (arg : args)   unApp other args = (other, args)-valueToJs opts m e (Let ds val) = do-  decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds-  ret <- valueToJs opts m e val+valueToJs m (Var _ ident) =+  return $ varToJs m ident+valueToJs m (Case _ values binders) = do+  vals <- mapM (valueToJs m) values+  bindersToJs m binders vals+valueToJs m (Let _ ds val) = do+  decls <- concat <$> mapM (bindToJs m) ds+  ret <- valueToJs m val   return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []-valueToJs opts m e (Abs (Left arg) val) = do-  ret <- valueToJs opts m e val-  return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])-valueToJs _ m _ (Var ident) = return $ varToJs m ident-valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val-valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val-valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"-valueToJs _ _ _ _ = error "Invalid argument to valueToJs"+valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =+  return $ JSVariableIntroduction ctor (Just $+              JSObjectLiteral [("create",+                JSFunction Nothing ["value"]+                  (JSBlock [JSReturn $ JSVar "value"]))])+valueToJs _ (Constructor _ _ (ProperName ctor) 0) =+  return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])+         , JSAssignment (JSAccessor "value" (JSVar ctor))+              (JSUnary JSNew $ JSApp (JSVar ctor) []) ]+valueToJs _ (Constructor _ _ (ProperName ctor) arity) =+  return $ iife ctor [ makeConstructor ctor arity+         , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity [])+         ]+    where+    makeConstructor :: String -> Int -> JS+    makeConstructor ctorName n =+      let args = [ "value" ++ show index | index <- [0..n-1] ]+          body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]+      in JSFunction (Just ctorName) args (JSBlock body)+    go :: String -> Int -> Int -> [JS] -> JS+    go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values)+    go pn index n values =+      JSFunction Nothing ["value" ++ show index]+        (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))]) +iife :: String -> [JS] -> JS+iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []++literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS+literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n+literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s+literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b+literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs+literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps+ -- | -- Shallow copy an object. --@@ -276,109 +241,111 @@ -- Generate code in the simplified Javascript intermediate representation for pattern match binders -- and guards. ---bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS-bindersToJs opts m e binders vals = do+bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS+bindersToJs m binders vals = do   valNames <- replicateM (length vals) freshName   let assignments = zipWith JSVariableIntroduction valNames (map Just vals)   jss <- forM binders $ \(CaseAlternative bs result) -> do     ret <- guardsToJs result     go valNames ret bs-  return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))+  return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))                  []   where-    go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> SupplyT m [JS]+    go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]     go _ done [] = return done     go (v:vs) done' (b:bs) = do       done'' <- go vs done' bs-      binderToJs m e v done'' b+      binderToJs m v done'' b     go _ _ _ = error "Invalid arguments to bindersToJs" -    guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS]+    guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]     guardsToJs (Left gs) = forM gs $ \(cond, val) -> do-      cond' <- valueToJs opts m e cond-      done  <- valueToJs opts m e val+      cond' <- valueToJs m cond+      done  <- valueToJs m val       return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing-    guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v+    guardsToJs (Right v) = return . JSReturn <$> valueToJs m v  -- | -- Generate code in the simplified Javascript intermediate representation for a pattern match -- binder. ---binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]-binderToJs _ _ _ done NullBinder = return done-binderToJs _ _ varName done (StringBinder str) =-  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]-binderToJs _ _ varName done (NumberBinder num) =-  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]-binderToJs _ _ varName done (BooleanBinder True) =-  return [JSIfElse (JSVar varName) (JSBlock done) Nothing]-binderToJs _ _ varName done (BooleanBinder False) =-  return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]-binderToJs _ _ varName done (VarBinder ident) =+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]+binderToJs _ _ done (NullBinder{}) = return done+binderToJs m varName done (LiteralBinder _ l) =+  literalToBinderJS m varName done l+binderToJs _ varName done (VarBinder _ ident) =   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)-binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =-  case bs of-    [b] -> binderToJs m e varName done b-    _ -> error "binder for newtype constructor should have a single argument"-binderToJs m e varName done (ConstructorBinder ctor bs) = do+binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =+  binderToJs m varName done b+binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType _)) _ ctor bs) = do   js <- go 0 done bs-  if isOnlyConstructor e ctor-  then-    return js-  else-    return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))-                     (JSBlock js)-                     Nothing]+  return $ case ctorType of+    ProductType -> js+    SumType ->+      [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))+                (JSBlock js)+                Nothing]   where-  go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]+  go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]   go _ done' [] = return done'   go index done' (binder:bs') = do     argVar <- freshName     done'' <- go (index + 1) done' bs'-    js <- binderToJs m e argVar done'' binder+    js <- binderToJs m argVar done'' binder     return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)-binderToJs m e varName done (ObjectBinder bs) = go done bs-  where-  go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]-  go done' [] = return done'-  go done' ((prop, binder):bs') = do-    propVar <- freshName-    done'' <- go done' bs'-    js <- binderToJs m e propVar done'' binder-    return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)-binderToJs m e varName done (ArrayBinder bs) = do-  js <- go done 0 bs-  return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]-  where-  go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]-  go done' _ [] = return done'-  go done' index (binder:bs') = do-    elVar <- freshName-    done'' <- go done' (index + 1) bs'-    js <- binderToJs m e elVar done'' binder-    return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)-binderToJs m e varName done binder@(ConsBinder _ _) = do+binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do   let (headBinders, tailBinder) = uncons [] binder       numberOfHeadBinders = fromIntegral $ length headBinders   js1 <- foldM (\done' (headBinder, index) -> do     headVar <- freshName-    jss <- binderToJs m e headVar done' headBinder+    jss <- binderToJs m headVar done' headBinder     return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])   tailVar <- freshName-  js2 <- binderToJs m e tailVar js1 tailBinder+  js2 <- binderToJs m tailVar js1 tailBinder   return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock     ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :       js2     )) Nothing]   where-  uncons :: [Binder] -> Binder -> ([Binder], Binder)-  uncons acc (ConsBinder h t) = uncons (h : acc) t-  uncons acc (PositionedBinder _ b) = uncons acc b+  uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)+  uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t   uncons acc tailBinder = (reverse acc, tailBinder)-binderToJs m e varName done (NamedBinder ident binder) = do-  js <- binderToJs m e varName done binder+binderToJs _ _ _ b@(ConstructorBinder{}) =+  error $ "Invalid ConstructorBinder in binderToJs: " ++ show b+binderToJs m varName done (NamedBinder _ ident binder) = do+  js <- binderToJs m varName done binder   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)-binderToJs m e varName done (PositionedBinder _ binder) =-  binderToJs m e varName done binder +literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]+literalToBinderJS _ varName done (NumericLiteral num) =+  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]+literalToBinderJS _ varName done (StringLiteral str) =+  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]+literalToBinderJS _ varName done (BooleanLiteral True) =+  return [JSIfElse (JSVar varName) (JSBlock done) Nothing]+literalToBinderJS _ varName done (BooleanLiteral False) =+  return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]+literalToBinderJS m varName done (ObjectLiteral bs) = go done bs+  where+  go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]+  go done' [] = return done'+  go done' ((prop, binder):bs') = do+    propVar <- freshName+    done'' <- go done' bs'+    js <- binderToJs m propVar done'' binder+    return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)+literalToBinderJS m varName done (ArrayLiteral bs) = do+  js <- go done 0 bs+  return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]+  where+  go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]+  go done' _ [] = return done'+  go done' index (binder:bs') = do+    elVar <- freshName+    done'' <- go done' (index + 1) bs'+    js <- binderToJs m elVar done'' binder+    return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js) +isCons :: Qualified ProperName -> Bool+isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"+isCons name = error $ "Unexpected argument in isCons: " ++ show name

@@ -19,6 +19,8 @@  import Data.Data +import Language.PureScript.Comments+ -- | -- Built-in unary operators --@@ -240,7 +242,11 @@   -- |   -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)   ---  | JSRaw String deriving (Show, Eq, Data, Typeable)+  | JSRaw String+  -- |+  -- Commented Javascript+  --+  | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable)  -- -- Traversals@@ -271,6 +277,7 @@   go (JSTypeOf js) = f (JSTypeOf (go js))   go (JSLabel name js) = f (JSLabel name (go js))   go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))+  go (JSComment com j) = f (JSComment com (go j))   go other = f other  everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS@@ -298,6 +305,7 @@   go (JSTypeOf j) = JSTypeOf (go (f j))   go (JSLabel name j) = JSLabel name (go (f j))   go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))+  go (JSComment com j) = JSComment com (go (f j))   go other = f other  everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r@@ -325,4 +333,5 @@   go j@(JSTypeOf j1) = f j <> go j1   go j@(JSLabel _ j1) = f j <> go j1   go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2+  go j@(JSComment _ j1) = f j <> go j1   go other = f other

@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.Common+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Common code generation utility functions+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Common where++import Data.Char+import Data.List (intercalate)++import Language.PureScript.Names++-- |+-- Convert an Ident into a valid Javascript identifier:+--+--  * Alphanumeric characters are kept unmodified.+--+--  * Reserved javascript identifiers are prefixed with '$$'.+--+--  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.+--+identToJs :: Ident -> String+identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name+identToJs (Ident name) = concatMap identCharToString name+identToJs (Op op) = concatMap identCharToString op++-- |+-- Test if a string is a valid JS identifier without escaping.+--+identNeedsEscaping :: String -> Bool+identNeedsEscaping s = s /= identToJs (Ident s)++-- |+-- Attempts to find a human-readable name for a symbol, if none has been specified returns the+-- ordinal value.+--+identCharToString :: Char -> String+identCharToString c | isAlphaNum c = [c]+identCharToString '_' = "_"+identCharToString '.' = "$dot"+identCharToString '$' = "$dollar"+identCharToString '~' = "$tilde"+identCharToString '=' = "$eq"+identCharToString '<' = "$less"+identCharToString '>' = "$greater"+identCharToString '!' = "$bang"+identCharToString '#' = "$hash"+identCharToString '%' = "$percent"+identCharToString '^' = "$up"+identCharToString '&' = "$amp"+identCharToString '|' = "$bar"+identCharToString '*' = "$times"+identCharToString '/' = "$div"+identCharToString '+' = "$plus"+identCharToString '-' = "$minus"+identCharToString ':' = "$colon"+identCharToString '\\' = "$bslash"+identCharToString '?' = "$qmark"+identCharToString '@' = "$at"+identCharToString '\'' = "$prime"+identCharToString c = '$' : show (ord c)++-- |+-- Checks whether an identifier name is reserved in Javascript.+--+nameIsJsReserved :: String -> Bool+nameIsJsReserved name =+  name `elem` [ "abstract"+              , "arguments"+              , "boolean"+              , "break"+              , "byte"+              , "case"+              , "catch"+              , "char"+              , "class"+              , "const"+              , "continue"+              , "debugger"+              , "default"+              , "delete"+              , "do"+              , "double"+              , "else"+              , "enum"+              , "eval"+              , "export"+              , "extends"+              , "final"+              , "finally"+              , "float"+              , "for"+              , "function"+              , "goto"+              , "if"+              , "implements"+              , "import"+              , "in"+              , "instanceof"+              , "int"+              , "interface"+              , "let"+              , "long"+              , "native"+              , "new"+              , "null"+              , "package"+              , "private"+              , "protected"+              , "public"+              , "return"+              , "short"+              , "static"+              , "super"+              , "switch"+              , "synchronized"+              , "this"+              , "throw"+              , "throws"+              , "transient"+              , "try"+              , "typeof"+              , "var"+              , "void"+              , "volatile"+              , "while"+              , "with"+              , "yield" ]++moduleNameToJs :: ModuleName -> String+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.Optimizer+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module optimizes code in the simplified-Javascript intermediate representation.+--+-- The following optimizations are supported:+--+--  * Collapsing nested blocks+--+--  * Tail call elimination+--+--  * Inlining of (>>=) and ret for the Eff monad+--+--  * Removal of unnecessary thunks+--+--  * Eta conversion+--+--  * Inlining variables+--+--  * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)+--+--  * Inlining primitive Javascript operators+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Optimizer (+    optimize+) where++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.Options+import qualified Language.PureScript.Constants as C++import Language.PureScript.CodeGen.JS.Optimizer.Common+import Language.PureScript.CodeGen.JS.Optimizer.TCO+import Language.PureScript.CodeGen.JS.Optimizer.MagicDo+import Language.PureScript.CodeGen.JS.Optimizer.Inliner+import Language.PureScript.CodeGen.JS.Optimizer.Unused+import Language.PureScript.CodeGen.JS.Optimizer.Blocks++-- |+-- Apply a series of optimizer passes to simplified Javascript code+--+optimize :: Options mode -> JS -> JS+optimize opts | optionsNoOptimizations opts = id+              | otherwise = untilFixedPoint (applyAll+  [ collapseNestedBlocks+  , collapseNestedIfs+  , tco opts+  , magicDo opts+  , removeCodeAfterReturnStatements+  , removeUnusedArg+  , removeUndefinedApp+  , unThunk+  , etaConvert+  , evaluateIifes+  , inlineVariables+  , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]+  , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]+  , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer+  , inlineCommonOperators ])++untilFixedPoint :: (Eq a) => (a -> a) -> a -> a+untilFixedPoint f = go+  where+  go a = let a' = f a in+          if a' == a then a' else go a'+

@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.Optimizer.Blocks+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Optimizer steps for simplifying Javascript blocks+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Optimizer.Blocks+  ( collapseNestedBlocks+  , collapseNestedIfs+  ) where++import Language.PureScript.CodeGen.JS.AST++-- |+-- Collapse blocks which appear nested directly below another block+--+collapseNestedBlocks :: JS -> JS+collapseNestedBlocks = everywhereOnJS collapse+  where+  collapse :: JS -> JS+  collapse (JSBlock sts) = JSBlock (concatMap go sts)+  collapse js = js+  go :: JS -> [JS]+  go (JSBlock sts) = sts+  go s = [s]++collapseNestedIfs :: JS -> JS+collapseNestedIfs = everywhereOnJS collapse+  where+  collapse :: JS -> JS+  collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =+      JSIfElse (JSBinary And cond1 cond2) body Nothing+  collapse js = js

@@ -0,0 +1,77 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.Optimizer.Common+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Common functions used by the various optimizer phases+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Optimizer.Common where++import Data.Maybe (fromMaybe)++import Language.PureScript.CodeGen.JS.AST++applyAll :: [a -> a] -> a -> a+applyAll = foldl1 (.)++replaceIdent :: String -> JS -> JS -> JS+replaceIdent var1 js = everywhereOnJS replace+  where+  replace (JSVar var2) | var1 == var2 = js+  replace other = other++replaceIdents :: [(String, JS)] -> JS -> JS+replaceIdents vars = everywhereOnJS replace+  where+  replace v@(JSVar var) = fromMaybe v $ lookup var vars+  replace other = other++isReassigned :: String -> JS -> Bool+isReassigned var1 = everythingOnJS (||) check+  where+  check :: JS -> Bool+  check (JSFunction _ args _) | var1 `elem` args = True+  check (JSVariableIntroduction arg _) | var1 == arg = True+  check (JSAssignment (JSVar arg) _) | var1 == arg = True+  check (JSFor arg _ _ _) | var1 == arg = True+  check (JSForIn arg _ _) | var1 == arg = True+  check _ = False++isRebound :: JS -> JS -> Bool+isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)+  where+  variablesOf (JSVar var) = [var]+  variablesOf _ = []++isUsed :: String -> JS -> Bool+isUsed var1 = everythingOnJS (||) check+  where+  check :: JS -> Bool+  check (JSVar var2) | var1 == var2 = True+  check (JSAssignment target _) | var1 == targetVariable target = True+  check _ = False++targetVariable :: JS -> String+targetVariable (JSVar var) = var+targetVariable (JSAccessor _ tgt) = targetVariable tgt+targetVariable (JSIndexer _ tgt) = targetVariable tgt+targetVariable _ = error "Invalid argument to targetVariable"++isUpdated :: String -> JS -> Bool+isUpdated var1 = everythingOnJS (||) check+  where+  check :: JS -> Bool+  check (JSAssignment target _) | var1 == targetVariable target = True+  check _ = False++removeFromBlock :: ([JS] -> [JS]) -> JS -> JS+removeFromBlock go (JSBlock sts) = JSBlock (go sts)+removeFromBlock _  js = js

@@ -0,0 +1,191 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.Optimizer.Inliner+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module provides basic inlining capabilities+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Optimizer.Inliner (+  inlineVariables,+  inlineOperator,+  inlineCommonOperators,+  etaConvert,+  unThunk,+  evaluateIifes+) where++import Data.Maybe (fromMaybe)++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.CodeGen.JS.Common+import Language.PureScript.Names+import Language.PureScript.CodeGen.JS.Optimizer.Common+import qualified Language.PureScript.Constants as C++shouldInline :: JS -> Bool+shouldInline (JSVar _) = True+shouldInline (JSNumericLiteral _) = True+shouldInline (JSStringLiteral _) = True+shouldInline (JSBooleanLiteral _) = True+shouldInline (JSAccessor _ val) = shouldInline val+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val+shouldInline _ = False++etaConvert :: JS -> JS+etaConvert = everywhereOnJS convert+  where+  convert :: JS -> JS+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])+    | all shouldInline args &&+      not (any (`isRebound` block) (map JSVar idents)) &&+      not (any (`isRebound` block) args)+      = JSBlock (map (replaceIdents (zip idents args)) body)+  convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn+  convert js = js++unThunk :: JS -> JS+unThunk = everywhereOnJS convert+  where+  convert :: JS -> JS+  convert (JSBlock []) = JSBlock []+  convert (JSBlock jss) =+    case last jss of+      JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body+      _ -> JSBlock jss+  convert js = js++evaluateIifes :: JS -> JS+evaluateIifes = everywhereOnJS convert+  where+  convert :: JS -> JS+  convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret+  convert js = js++inlineVariables :: JS -> JS+inlineVariables = everywhereOnJS $ removeFromBlock go+  where+  go :: [JS] -> [JS]+  go [] = []+  go (JSVariableIntroduction var (Just js) : sts)+    | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =+      go (map (replaceIdent var js) sts)+  go (s:sts) = s : go sts++inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS+inlineOperator (m, op) f = everywhereOnJS convert+  where+  convert :: JS -> JS+  convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y+  convert other = other+  isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)+  isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'+  isOp _ = False++inlineCommonOperators :: JS -> JS+inlineCommonOperators = applyAll $+  [ binary C.numNumber (C.+) Add+  , binary C.numNumber (C.-) Subtract+  , binary C.numNumber (C.*) Multiply+  , binary C.numNumber (C./) Divide+  , binary C.numNumber (C.%) Modulus+  , unary  C.numNumber C.negate Negate++  , binary C.ordNumber (C.<) LessThan+  , binary C.ordNumber (C.>) GreaterThan+  , binary C.ordNumber (C.<=) LessThanOrEqualTo+  , binary C.ordNumber (C.>=) GreaterThanOrEqualTo++  , binary C.eqNumber (C.==) EqualTo+  , binary C.eqNumber (C./=) NotEqualTo+  , binary C.eqString (C.==) EqualTo+  , binary C.eqString (C./=) NotEqualTo+  , binary C.eqBoolean (C.==) EqualTo+  , binary C.eqBoolean (C./=) NotEqualTo++  , binary C.semigroupString (C.<>) Add+  , binary C.semigroupString (C.++) Add++  , binaryFunction C.bitsNumber C.shl ShiftLeft+  , binaryFunction C.bitsNumber C.shr ShiftRight+  , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight+  , binary         C.bitsNumber (C..&.) BitwiseAnd+  , binary         C.bitsNumber (C..|.) BitwiseOr+  , binary         C.bitsNumber (C..^.) BitwiseXor+  , unary          C.bitsNumber C.complement BitwiseNot++  , binary C.boolLikeBoolean (C.&&) And+  , binary C.boolLikeBoolean (C.||) Or+  , unary  C.boolLikeBoolean C.not Not+  ] +++  [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]+  where+  binary :: String -> String -> BinaryOperator -> JS -> JS+  binary dictName opString op = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y+    convert other = other+    isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)+    isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'+    isOp _ = False+  binaryFunction :: String -> String -> BinaryOperator -> JS -> JS+  binaryFunction dictName fnName op = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y+    convert other = other+    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'+    isOp _ = False+  unary :: String -> String -> UnaryOperator -> JS -> JS+  unary dictName fnName op = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x+    convert other = other+    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName+    isOp _ = False+  isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName+  isOpDict _ _ = False+  mkFn :: Int -> JS -> JS+  mkFn 0 = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =+      JSFunction Nothing [] (JSBlock js)+    convert other = other+  mkFn n = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =+      case collectArgs n [] fn of+        Just (args, js) -> JSFunction Nothing args (JSBlock js)+        Nothing -> orig+    convert other = other+    collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])+    collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)+    collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret+    collectArgs _ _   _ = Nothing++  isNFn :: String -> Int -> JS -> Bool+  isNFn prefix n (JSVar name) = name == (prefix ++ show n)+  isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)+  isNFn _ _ _ = False++  runFn :: Int -> JS -> JS+  runFn n = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert js = fromMaybe js $ go n [] js++    go :: Int -> [JS] -> JS -> Maybe JS+    go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)+    go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs+    go _ _   _ = Nothing

@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.Optimizer.MagicDo+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module implements the "Magic Do" optimization, which inlines calls to return+-- and bind for the Eff monad, as well as some of its actions.+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (+  magicDo+) where++import Data.List (nub)+import Data.Maybe (fromJust, isJust)++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.CodeGen.JS.Common+import Language.PureScript.Names+import Language.PureScript.Options+import qualified Language.PureScript.Constants as C++magicDo :: Options mode -> JS -> JS+magicDo opts | optionsNoMagicDo opts = id+             | otherwise = inlineST . magicDo'++-- |+-- Inline type class dictionaries for >>= and return for the Eff monad+--+-- E.g.+--+--  Prelude[">>="](dict)(m1)(function(x) {+--    return ...;+--  })+--+-- becomes+--+--  function __do {+--    var x = m1();+--    ...+--  }+--+magicDo' :: JS -> JS+magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert+  where+  -- The name of the function block which is added to denote a do block+  fnName = "__do"+  -- Desugar monomorphic calls to >>= and return for the Eff monad+  convert :: JS -> JS+  -- Desugar return+  convert (JSApp (JSApp ret [val]) []) | isReturn ret = val+  -- Desugar pure+  convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val+  -- Desugar >>+  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =+    JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )+  -- Desugar >>=+  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =+    JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)+  -- Desugar untilE+  convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =+    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []+  -- Desugar whileE+  convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =+    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []+  convert other = other+  -- Check if an expression represents a monomorphic call to >>= for the Eff monad+  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True+  isBind _ = False+  -- Check if an expression represents a monomorphic call to return for the Eff monad+  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True+  isReturn _ = False+  -- Check if an expression represents a monomorphic call to pure for the Eff applicative+  isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True+  isPure _ = False+  -- Check if an expression represents the polymorphic >>= function+  isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))+  isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)+  isBindPoly _ = False+  -- Check if an expression represents the polymorphic return function+  isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped+  isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return+  isRetPoly _ = False+  -- Check if an expression represents the polymorphic pure function+  isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'+  isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'+  isPurePoly _ = False+  -- Check if an expression represents a function in the Ef module+  isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'+  isEffFunc _ _ = False+  -- Check if an expression represents the Monad Eff dictionary+  isEffDict name (JSVar ident) | ident == name = True+  isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name+  isEffDict _ _ = False+  -- Remove __do function applications which remain after desugaring+  undo :: JS -> JS+  undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body+  undo other = other++  applyReturns :: JS -> JS+  applyReturns (JSReturn ret) = JSReturn (JSApp ret [])+  applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)+  applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)+  applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)+  applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)+  applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)+  applyReturns other = other++-- |+-- Inline functions in the ST module+--+inlineST :: JS -> JS+inlineST = everywhereOnJS convertBlock+  where+  -- Look for runST blocks and inline the STRefs there.+  -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then+  -- we can be more aggressive about inlining, and actually turn STRefs into local variables.+  convertBlock (JSApp f [arg]) | isSTFunc C.runST f =+    let refs = nub . findSTRefsIn $ arg+        usages = findAllSTUsagesIn arg+        allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages+        localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs+    in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg+  convertBlock other = other+  -- Convert a block in a safe way, preserving object wrappers of references,+  -- or in a more aggressive way, turning wrappers into local variables depending on the+  -- agg(ressive) parameter.+  convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =+   JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])+  convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =+    if agg then ref else JSAccessor C.stRefValue ref+  convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =+    if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg+  convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =+    if agg then JSAssignment ref (JSApp func [ref]) else  JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])+  convert _ other = other+  -- Check if an expression represents a function in the ST module+  isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'+  isSTFunc _ _ = False+  -- Find all ST Refs initialized in this block+  findSTRefsIn = everythingOnJS (++) isSTRef+    where+    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]+    isSTRef _ = []+  -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef+  findAllSTUsagesIn = everythingOnJS (++) isSTUsage+    where+    isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]+    isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]+    isSTUsage _ = []+  -- Find all uses of a variable+  appearingIn ref = everythingOnJS (++) isVar+    where+    isVar e@(JSVar v) | v == ref = [e]+    isVar _ = []+  -- Convert a JS value to a String if it is a JSVar+  toVar (JSVar v) = Just v+  toVar _ = Nothing

@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.Optimizer.TCO+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module implements tail call elimination.+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where++import Language.PureScript.Options+import Language.PureScript.CodeGen.JS.AST++-- |+-- Eliminate tail calls+--+tco :: Options mode -> JS -> JS+tco opts | optionsNoTco opts = id+         | otherwise = tco'++tco' :: JS -> JS+tco' = everywhereOnJS convert+  where+  tcoLabel :: String+  tcoLabel = "tco"+  tcoVar :: String -> String+  tcoVar arg = "__tco_" ++ arg+  copyVar :: String -> String+  copyVar arg = "__copy_" ++ arg+  convert :: JS -> JS+  convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =+    let+      (argss, body', replace) = collectAllFunctionArgs [] id fn+    in case () of+      _ | isTailCall name body' ->+            let+              allArgs = concat $ reverse argss+            in+              JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))+        | otherwise -> js+  convert js = js+  collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)+  collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =+    collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body+  collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =+    (args : allArgs, body, f . JSFunction ident (map copyVar args))+  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =+    collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body+  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =+    (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))+  collectAllFunctionArgs allArgs f body = (allArgs, body, f)+  isTailCall :: String -> JS -> Bool+  isTailCall ident js =+    let+      numSelfCalls = everythingOnJS (+) countSelfCalls js+      numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js+      numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js+    in+      numSelfCalls > 0+      && numSelfCalls == numSelfCallsInTailPosition+      && numSelfCallsUnderFunctions == 0+    where+    countSelfCalls :: JS -> Int+    countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1+    countSelfCalls _ = 0+    countSelfCallsInTailPosition :: JS -> Int+    countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1+    countSelfCallsInTailPosition _ = 0+    countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'+    countSelfCallsUnderFunctions _ = 0+  toLoop :: String -> [String] -> JS -> JS+  toLoop ident allArgs js = JSBlock $+        map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs +++        [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]+    where+    loopify :: JS -> JS+    loopify (JSReturn ret) | isSelfCall ident ret =+      let+        allArgumentValues = concat $ collectSelfCallArgs [] ret+      in+        JSBlock $ zipWith (\val arg ->+                    JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs+                  ++ map (\arg ->+                    JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs+                  ++ [ JSContinue tcoLabel ]+    loopify other = other+    collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]+    collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn+    collectSelfCallArgs allArgumentValues _ = allArgumentValues+  isSelfCall :: String -> JS -> Bool+  isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True+  isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn+  isSelfCall _ _ = False+  isFunction :: JS -> Bool+  isFunction (JSFunction _ _ _) = True+  isFunction _ = False

@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.Optimizer.Unused+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Removes unused variables+--+-----------------------------------------------------------------------------++module Language.PureScript.CodeGen.JS.Optimizer.Unused+  ( removeCodeAfterReturnStatements+  , removeUnusedArg+  , removeUndefinedApp+  ) where++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.CodeGen.JS.Optimizer.Common++import qualified Language.PureScript.Constants as C++removeCodeAfterReturnStatements :: JS -> JS+removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)+  where+  go :: [JS] -> [JS]+  go jss | not (any isJSReturn jss) = jss+         | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]+  isJSReturn (JSReturn _) = True+  isJSReturn _ = False++removeUnusedArg :: JS -> JS+removeUnusedArg = everywhereOnJS convert+  where+  convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body+  convert js = js++removeUndefinedApp :: JS -> JS+removeUndefinedApp = everywhereOnJS convert+  where+  convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []+  convert js = js

@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.Comments+-- Copyright   :  (c) Phil Freeman 2015+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Defines the types of source code comments+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.Comments where++import qualified Data.Data as D+    +data Comment+  = LineComment String+  | BlockComment String+  deriving (Show, Eq, Ord, D.Data, D.Typeable)

@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | The core functional representation+--+-----------------------------------------------------------------------------++module Language.PureScript.CoreFn (+  module C+) where++import Language.PureScript.CoreFn.Ann as C+import Language.PureScript.CoreFn.Binders as C+import Language.PureScript.CoreFn.Desugar as C+import Language.PureScript.CoreFn.Expr as C+import Language.PureScript.CoreFn.Literals as C+import Language.PureScript.CoreFn.Meta as C+import Language.PureScript.CoreFn.Module as C+import Language.PureScript.CoreFn.Traversals as C

@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Ann+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | Type alias for basic annotations+--+-----------------------------------------------------------------------------++module Language.PureScript.CoreFn.Ann where++import Language.PureScript.AST.SourcePos+import Language.PureScript.CoreFn.Meta+import Language.PureScript.Types+import Language.PureScript.Comments++-- |+-- Type alias for basic annotations+--+type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta)++-- |+-- Initial annotation with no metadata+--+nullAnn :: Ann+nullAnn = (Nothing, [], Nothing, Nothing)++-- |+-- Remove the comments from an annotation+--+removeComments :: Ann -> Ann+removeComments (ss, _, ty, meta) = (ss, [], ty, meta)

@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Binders+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | The core functional representation for binders+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.CoreFn.Binders where++import qualified Data.Data as D++import Language.PureScript.CoreFn.Literals+import Language.PureScript.Names++-- |+-- Data type for binders+--+data Binder a+  -- |+  -- Wildcard binder+  --+  = NullBinder a+  -- |+  -- A binder which matches a literal value+  --+  | LiteralBinder a (Literal (Binder a))+  -- |+  -- A binder which binds an identifier+  --+  | VarBinder a Ident+  -- |+  -- A binder which matches a data constructor (type name, constructor name, binders)+  --+  | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]+  -- |+  -- A binder which binds its input to an identifier+  --+  | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable)

@@ -0,0 +1,242 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Desugar+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | The AST -> CoreFn desugaring step+--+-----------------------------------------------------------------------------++module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where++import Data.Function (on)+import Data.List (sort, sortBy, nub)+import Data.Maybe (mapMaybe)+import qualified Data.Map as M++import Control.Arrow (second, (***))++import Language.PureScript.AST.SourcePos+import Language.PureScript.AST.Traversals+import Language.PureScript.CoreFn.Ann+import Language.PureScript.CoreFn.Binders+import Language.PureScript.CoreFn.Expr+import Language.PureScript.CoreFn.Literals+import Language.PureScript.CoreFn.Meta+import Language.PureScript.CoreFn.Module+import Language.PureScript.Environment+import Language.PureScript.Names+import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)+import Language.PureScript.Types+import Language.PureScript.Comments+import qualified Language.PureScript.AST as A++-- |+-- Desugars a module from AST to CoreFn representation.+--+moduleToCoreFn :: Environment -> A.Module -> Module Ann+moduleToCoreFn env (A.Module mn decls (Just exps)) =+  let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls+      exps' = nub $ concatMap exportToCoreFn exps+      externs = nub $ mapMaybe externToCoreFn decls+      decls' = concatMap (declToCoreFn env Nothing []) decls+  in Module mn imports exps' externs decls'+moduleToCoreFn _ (A.Module{}) =+  error "Module exports were not elaborated before moduleToCoreFn"++findQualModules :: [A.Declaration] -> [ModuleName]+findQualModules decls =+  let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])+  in f `concatMap` decls+  where+  fqValues :: A.Expr -> [ModuleName]+  fqValues (A.Var (Qualified (Just mn) _)) = [mn]+  fqValues _ = []++-- |+-- Desugars import declarations from AST to CoreFn representation.+--+importToCoreFn :: A.Declaration -> Maybe ModuleName+importToCoreFn (A.ImportDeclaration name _ _) = Just name+importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d+importToCoreFn _ = Nothing++-- |+-- Desugars foreign declarations from AST to CoreFn representation.+--+externToCoreFn :: A.Declaration -> Maybe ForeignDecl+externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)+externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)+externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d+externToCoreFn _ = Nothing++-- |+-- Desugars export declarations references from AST to CoreFn representation.+-- CoreFn modules only export values, so all data constructors, class+-- constructor, instances and values are flattened into one list.+--+exportToCoreFn :: A.DeclarationRef -> [Ident]+exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors+exportToCoreFn (A.ValueRef name) = [name]+exportToCoreFn (A.TypeClassRef name) = [properToIdent name]+exportToCoreFn (A.TypeInstanceRef name) = [name]+exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d+exportToCoreFn _ = []++-- |+-- Desugars member declarations from AST to CoreFn representation.+--+declToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]+declToCoreFn _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =+  [NonRec (properToIdent ctor) $+    Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]+declToCoreFn _ _ _ d@(A.DataDeclaration Newtype _ _ _) =+  error $ "Found newtype with multiple constructors: " ++ show d+declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =+  flip map ctors $ \(ctor, tys) ->+    NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor (length tys)+declToCoreFn env ss _   (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds+declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =+  [NonRec name (exprToCoreFn env ss com Nothing e)]+declToCoreFn env ss _   (A.BindingGroupDeclaration ds) =+  [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss [] Nothing e)) ds]+declToCoreFn _   ss com (A.TypeClassDeclaration name _ supers members) =+  [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]+declToCoreFn env _  com (A.PositionedDeclaration ss com1 d) =+  declToCoreFn env (Just ss) (com ++ com1) d+declToCoreFn _ _ _ _ = []++-- |+-- Makes a typeclass dictionary constructor function. The returned expression+-- is a function that accepts the superclass instances and member+-- implementations and returns a record for the instance dictionary.+--+mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann+mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])+mkTypeClassConstructor ss com supers members =+  let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers+      props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]+      dict = Literal nullAnn (ObjectLiteral props)+  in Abs (ss, com, Nothing, Just IsTypeClassConstructor)+         (Ident a)+         (foldr (Abs nullAnn . Ident) dict as)++-- |+-- Desugars expressions from AST to CoreFn representation.+--+exprToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann+exprToCoreFn _ ss com ty (A.NumericLiteral v) =+  Literal (ss, com, ty, Nothing) (NumericLiteral v)+exprToCoreFn _ ss com ty (A.StringLiteral v) =+  Literal (ss, com, ty, Nothing) (StringLiteral v)+exprToCoreFn _ ss com ty (A.BooleanLiteral v) =+  Literal (ss, com, ty, Nothing) (BooleanLiteral v)+exprToCoreFn env ss com ty (A.ArrayLiteral vs) =+  Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss [] Nothing) vs)+exprToCoreFn env ss com ty (A.ObjectLiteral vs) =+  Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss [] Nothing)) vs)+exprToCoreFn env ss com ty (A.Accessor name v) =+  Accessor (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)+exprToCoreFn env ss com ty (A.ObjectUpdate obj vs) =+  ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing obj) $ map (second (exprToCoreFn env ss [] Nothing)) vs+exprToCoreFn env ss com ty (A.Abs (Left name) v) =+  Abs (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)+exprToCoreFn _ _ _ _ (A.Abs _ _) =+  error "Abs with Binder argument was not desugared before exprToCoreFn"+exprToCoreFn env ss com ty (A.App v1 v2) =+  App (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing v1) (exprToCoreFn env ss [] Nothing v2)+exprToCoreFn _ ss com ty (A.Var ident) =+  Var (ss, com, ty, Nothing) ident+exprToCoreFn env ss com ty (A.IfThenElse v1 v2 v3) =+  Case (ss, com, ty, Nothing) [exprToCoreFn env ss [] Nothing v1]+    [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]+                      (Right $ exprToCoreFn env Nothing [] Nothing v2)+    , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]+                      (Right $ exprToCoreFn env Nothing [] Nothing v3) ]+exprToCoreFn env ss com ty (A.Constructor name) =+  Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name+exprToCoreFn env ss com ty (A.Case vs alts) =+  Case (ss, com, ty, Nothing) (map (exprToCoreFn env ss [] Nothing) vs) (map (altToCoreFn env ss) alts)+exprToCoreFn env ss com _ (A.TypedValue _ v ty) =+  exprToCoreFn env ss com (Just ty) v+exprToCoreFn env ss com ty (A.Let ds v) =+  Let (ss, com, ty, Nothing) (concatMap (declToCoreFn env ss []) ds) (exprToCoreFn env ss [] Nothing v)+exprToCoreFn env ss com _  (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =+  let args = map (exprToCoreFn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs+      ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)+  in foldl (App (ss, com, Nothing, Nothing)) ctor args+exprToCoreFn env _ com ty (A.PositionedValue ss com1 v) =+  exprToCoreFn env (Just ss) (com ++ com1) ty v+exprToCoreFn _ _ _ _ e =+  error $ "Unexpected value in exprToCoreFn: " ++ show e++-- |+-- Desugars case alternatives from AST to CoreFn representation.+--+altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann+altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)+  where+  go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)+  go (Left ges) = Left $ map (exprToCoreFn env ss [] Nothing *** exprToCoreFn env ss [] Nothing) ges+  go (Right e) = Right (exprToCoreFn env ss [] Nothing e)++-- |+-- Desugars case binders from AST to CoreFn representation.+--+binderToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann+binderToCoreFn _ ss com (A.NullBinder) =+  NullBinder (ss, com, Nothing, Nothing)+binderToCoreFn _ ss com (A.BooleanBinder b) =+  LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)+binderToCoreFn _ ss com (A.StringBinder s) =+  LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)+binderToCoreFn _ ss com (A.NumberBinder n) =+  LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)+binderToCoreFn _ ss com (A.VarBinder name) =+  VarBinder (ss, com, Nothing, Nothing) name+binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =+  let (_, tctor, _) = lookupConstructor env dctor+  in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)+binderToCoreFn env ss com (A.ObjectBinder bs) =+  LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)+binderToCoreFn env ss com (A.ArrayBinder bs) =+  LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss []) bs)+binderToCoreFn env ss com (A.ConsBinder b1 b2) =+  let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")+  in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss []) [b1, b2]+binderToCoreFn env ss com (A.NamedBinder name b) =+  NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn env ss [] b)+binderToCoreFn env _ com (A.PositionedBinder ss com1 b) =+  binderToCoreFn env (Just ss) (com ++ com1) b++-- |+-- Converts a ProperName to an Ident.+--+properToIdent :: ProperName -> Ident+properToIdent = Ident . runProperName++-- |+-- Gets metadata for data constructors.+--+getConstructorMeta :: Environment -> Qualified ProperName -> Meta+getConstructorMeta env ctor =+  case lookupConstructor env ctor of+    (Newtype, _, _) -> IsNewtype+    dc@(Data, _, ty) ->+      let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType+      in IsConstructor constructorType (getArity ty)+  where+  getArity :: Type -> Int+  getArity (TypeApp (TypeApp f _) t) | f == tyFunction = getArity t + 1+  getArity (ForAll _ ty _) = getArity ty+  getArity _ = 0+  numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int+  numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env+  typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)+  typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor)+  typeConstructor _ = error "Invalid argument to typeConstructor"

@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Expr+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | The core functional representation+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.CoreFn.Expr where++import qualified Data.Data as D++import Language.PureScript.CoreFn.Binders+import Language.PureScript.CoreFn.Literals+import Language.PureScript.CoreFn.Meta+import Language.PureScript.Names++-- |+-- Data type for expressions and terms+--+data Expr a+  -- |+  -- A literal value+  --+  = Literal a (Literal (Expr a))+  -- |+  -- A data constructor (type name, constructor name, arity)+  --+  | Constructor a ProperName ProperName Arity+  -- |+  -- A record property accessor+  --+  | Accessor a String (Expr a)+  -- |+  -- Partial record update+  --+  | ObjectUpdate a (Expr a) [(String, Expr a)]+  -- |+  -- Function introduction+  --+  | Abs a Ident (Expr a)+  -- |+  -- Function application+  --+  | App a (Expr a) (Expr a)+  -- |+  -- Variable+  --+  | Var a (Qualified Ident)+  -- |+  -- A case expression+  --+  | Case a [Expr a] [CaseAlternative a]+  -- |+  -- A let binding+  --+  | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable)++-- |+-- A let or module binding.+--+data Bind a+  -- |+  -- Non-recursive binding for a single value+  --+  = NonRec Ident (Expr a)+  -- |+  -- Mutually recursive binding group for several values+  --+  | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)++-- |+-- A guard is just a boolean-valued expression that appears alongside a set of binders+--+type Guard a = Expr a++-- |+-- An alternative in a case statement+--+data CaseAlternative a = CaseAlternative+  { -- |+    -- A collection of binders with which to match the inputs+    --+    caseAlternativeBinders :: [Binder a]+    -- |+    -- The result expression or a collect of guarded expressions+    --+  , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)+  } deriving (Show, D.Data, D.Typeable)++-- |+-- Extract the annotation from a term+--+extractAnn :: Expr a -> a+extractAnn (Literal a _) = a+extractAnn (Constructor a _ _ _) = a+extractAnn (Accessor a _ _) = a+extractAnn (ObjectUpdate a _ _) = a+extractAnn (Abs a _ _) = a+extractAnn (App a _ _) = a+extractAnn (Var a _) = a+extractAnn (Case a _ _) = a+extractAnn (Let a _ _) = a++-- |+-- Modify the annotation on a term+--+modifyAnn :: (a -> a) -> Expr a -> Expr a+modifyAnn f (Literal a b)         = Literal (f a) b+modifyAnn f (Constructor a b c d) = Constructor (f a) b c d+modifyAnn f (Accessor a b c)      = Accessor (f a) b c+modifyAnn f (ObjectUpdate a b c)  = ObjectUpdate (f a) b c+modifyAnn f (Abs a b c)           = Abs (f a) b c+modifyAnn f (App a b c)           = App (f a) b c+modifyAnn f (Var a b)             = Var (f a) b+modifyAnn f (Case a b c)          = Case (f a) b c+modifyAnn f (Let a b c)           = Let (f a) b c

@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Literals+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | The core functional representation for literal values.+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.CoreFn.Literals where++import qualified Data.Data as D++-- |+-- Data type for literal values. Parameterised so it can be used for Exprs and+-- Binders.+--+data Literal a+  -- |+  -- A numeric literal+  --+  = NumericLiteral (Either Integer Double)+  -- |+  -- A string literal+  --+  | StringLiteral String+  -- |+  -- A boolean literal+  --+  | BooleanLiteral Bool+  -- |+  -- An array literal+  --+  | ArrayLiteral [a]+  -- |+  -- An object literal+  --+  | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)

@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Meta+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | Metadata annotations for core functional representation+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.CoreFn.Meta where++import qualified Data.Data as D++-- |+-- Metadata annotations+--+data Meta+  -- |+  -- The contained value is a data constructor+  --+  = IsConstructor ConstructorType Arity+  -- |+  -- The contained value is a newtype+  --+  | IsNewtype+  -- |+  -- The contained value is a typeclass dictionary constructor+  --+  | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)++-- |+-- Type alias for constructor arity+--+type Arity = Int++-- |+-- Data constructor metadata+--+data ConstructorType+  -- |+  -- The constructor is for a type with a single construcor+  --+  = ProductType+  -- |+  -- The constructor is for a type with multiple construcors+  --+  | SumType deriving (Show, D.Data, D.Typeable)

@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Module+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | The CoreFn module representation+--+-----------------------------------------------------------------------------++module Language.PureScript.CoreFn.Module where++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.CoreFn.Expr+import Language.PureScript.Names+import Language.PureScript.Types++data Module a = Module+  { moduleName :: ModuleName+  , moduleImports :: [ModuleName]+  , moduleExports :: [Ident]+  , moduleForeign :: [ForeignDecl]+  , moduleDecls :: [Bind a]+  } deriving (Show)++type ForeignDecl = (Ident, Maybe JS, Type)

@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CoreFn.Traversals+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>+-- Stability   :  experimental+-- Portability :+--+-- | CoreFn traversal helpers+--+-----------------------------------------------------------------------------++module Language.PureScript.CoreFn.Traversals where++import Control.Arrow (second, (***), (+++))++import Language.PureScript.CoreFn.Binders+import Language.PureScript.CoreFn.Expr+import Language.PureScript.CoreFn.Literals++everywhereOnValues :: (Bind a -> Bind a) ->+                      (Expr a -> Expr a) ->+                      (Binder a -> Binder a) ->+                      (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)+everywhereOnValues f g h = (f', g', h')+  where+  f' (NonRec name e) = f (NonRec name (g' e))+  f' (Rec es) = f (Rec (map (second g') es))++  g' (Literal ann e) = g (Literal ann (handleLiteral g' e))+  g' (Accessor ann prop e) = g (Accessor ann prop (g' e))+  g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))+  g' (Abs ann name e) = g (Abs ann name (g' e))+  g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))+  g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))+  g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))+  g' e = g e++  h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))+  h' (NamedBinder a name b) = h (NamedBinder a name (h' b))+  h' b = h b++  handleCaseAlternative ca =+    ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)+       , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)+       }++  handleLiteral :: (a -> a) -> Literal a -> Literal a+  handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)+  handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)+  handleLiteral _ other = other++everythingOnValues :: (r -> r -> r) ->+                      (Bind a -> r) ->+                      (Expr a -> r) ->+                      (Binder a -> r) ->+                      (CaseAlternative a -> r) ->+                      (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)+everythingOnValues (<>) f g h i = (f', g', h', i')+  where+  f' b@(NonRec _ e) = f b <> g' e+  f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)++  g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))+  g' v@(Accessor _ _ e1) = g v <> g' e1+  g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)+  g' v@(Abs _ _ e1) = g v <> g' e1+  g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2+  g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)+  g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1+  g' v = g v++  h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))+  h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)+  h' b@(NamedBinder _ _ b1) = h b <> h' b1+  h' b = h b++  i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val+  i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)++  extractLiteral (ArrayLiteral xs) = xs+  extractLiteral (ObjectLiteral xs) = map snd xs+  extractLiteral _ = []

@@ -8,7 +8,7 @@ -- Stability   :  experimental -- Portability : ----- |+-- | Dead code elimination. -- ----------------------------------------------------------------------------- @@ -16,98 +16,87 @@   eliminateDeadCode ) where -import Data.List import Data.Graph+import Data.List import Data.Maybe (mapMaybe) +import Language.PureScript.CoreFn import Language.PureScript.Names-import Language.PureScript.AST  -- | -- Eliminate all declarations which are not a transitive dependency of the entry point module ---eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]+eliminateDeadCode :: [ModuleName] -> [Module a] -> [Module a] eliminateDeadCode entryPoints ms = map go ms   where-  go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')+  go (Module mn imps exps foreigns ds) = Module mn imps exps' foreigns' ds'     where-    ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds-    exps' = mapMaybe (filterExport ds') exps-  go _ = error "Exports should have been elaborated in name desugaring"+    ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds+    foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns+    names = concatMap bindIdents ds' ++ map foreignIdent foreigns'+    exps' = filter (`elem` names) exps   declarations = concatMap declarationsByModule ms   (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations   entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations -  filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef-  filterExport decls r@(TypeRef name _) | (any $ typeOrClassExists name) decls = Just r-  filterExport decls r@(TypeClassRef name) | (any $ typeOrClassExists name) decls = Just r-  filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r-  filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r-  filterExport _ _ = Nothing--  valueExists :: Ident -> Declaration -> Bool-  valueExists name (ValueDeclaration name' _ _ _) = name == name'-  valueExists name (ExternDeclaration _ name' _ _) = name == name'-  valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls-  valueExists name (PositionedDeclaration _ d) = valueExists name d-  valueExists _ _ = False+-- |+-- Extract declaration names for a binding group.+--+bindIdents :: Bind a -> [Ident]+bindIdents (NonRec name _) = [name]+bindIdents (Rec names) = map fst names -  typeOrClassExists :: ProperName -> Declaration -> Bool-  typeOrClassExists name (DataDeclaration _ name' _ _) = name == name'-  typeOrClassExists name (TypeClassDeclaration name' _ _ _) = name == name'-  typeOrClassExists name (DataBindingGroupDeclaration decls) = any (typeOrClassExists name) decls-  typeOrClassExists name (PositionedDeclaration _ d) = typeOrClassExists name d-  typeOrClassExists _ _ = False+-- |+-- Extract the ident for a foreign declaration.+--+foreignIdent :: ForeignDecl -> Ident+foreignIdent (name, _, _) = name -type Key = (ModuleName, Either Ident ProperName)+-- |+-- Key type to use in graph+--+type Key = (ModuleName, Ident) -declarationsByModule :: Module -> [(Key, [Key])]-declarationsByModule (Module moduleName ds _) = concatMap go ds+-- |+-- Find dependencies for each member in a module.+--+declarationsByModule :: Module a -> [(Key, [Key])]+declarationsByModule (Module mn _ _ fs ds) =+  let fs' = map ((\name -> ((mn, name), [])) . foreignIdent) fs+  in fs' ++ concatMap go ds   where-  go :: Declaration -> [(Key, [Key])]-  go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]-  go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors-  go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]-  go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'-  go (DataBindingGroupDeclaration ds') = concatMap go ds'-  go (TypeClassDeclaration name _ _ _) = [((moduleName, Right name), [])]-  go (PositionedDeclaration _ d) = go d-  go _ = []+  go :: Bind a -> [(Key, [Key])]+  go d@(NonRec name _) = [((mn, name), dependencies d)]+  go d@(Rec names') = map (\(name, _) -> ((mn, name), dependencies d)) names' -dependencies :: ModuleName -> Declaration -> [Key]-dependencies moduleName =-  let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])+-- |+-- Find all referenced values within a binding group.+--+dependencies :: Bind a -> [Key]+dependencies =+  let (f, _, _, _) = everythingOnValues (++) (const []) values binders (const [])   in nub . f   where-  values :: Expr -> [Key]-  values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]-  values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]-  values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"-  values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]-  values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"+  values :: Expr a -> [Key]+  values (Var _ (Qualified (Just mn) ident)) = [(mn, ident)]   values _ = []+  binders :: Binder a -> [Key]+  binders (ConstructorBinder _ _ (Qualified (Just mn) ident) _) = [(mn, Ident $ runProperName ident)]+  binders _ = [] -isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool-isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =-  let Just v' = vertexFor (moduleName, Left name)-  in any (\v -> path graph v v') entryPointVertices-isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =-  let Just v' = vertexFor (moduleName, Left $ Op name)-  in any (\v -> path graph v v') entryPointVertices-isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =-  any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)-                   in any (\v -> path graph v v') entryPointVertices) dctors-isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =-  let Just v' = vertexFor (moduleName, Left name)-  in any (\v -> path graph v v') entryPointVertices-isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =-  any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)-                        in any (\v -> path graph v v') entryPointVertices) ds-isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =-  any (isUsed moduleName graph vertexFor entryPointVertices) ds-isUsed moduleName graph vertexFor entryPointVertices (TypeClassDeclaration name _ _ _) =-  let Just v' = vertexFor (moduleName, Right name)+-- |+-- Check whether a binding group is used.+--+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Bind a -> Bool+isUsed mn graph vertexFor entryPointVertices (NonRec name _) =+  isUsed' mn graph vertexFor entryPointVertices name+isUsed mn graph vertexFor entryPointVertices (Rec ds) =+  any (isUsed' mn graph vertexFor entryPointVertices . fst) ds++-- |+-- Check whether a named declaration is used.+--+isUsed' :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Ident -> Bool+isUsed' mn graph vertexFor entryPointVertices name =+  let Just v' = vertexFor (mn, name)   in any (\v -> path graph v v') entryPointVertices-isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =-  isUsed moduleName graph vertexFor entryPointVertices d-isUsed _ _ _ _ _ = True

@@ -17,15 +17,15 @@ module Language.PureScript.Environment where  import Data.Data+import Data.Maybe (fromMaybe)+import qualified Data.Map as M -import Language.PureScript.Names-import Language.PureScript.Types import Language.PureScript.Kinds+import Language.PureScript.Names import Language.PureScript.TypeClassDictionaries+import Language.PureScript.Types import qualified Language.PureScript.Constants as C -import qualified Data.Map as M- -- | -- The @Environment@ defines all values and types which are currently in scope: --@@ -53,7 +53,7 @@   -- |   -- Type classes   ---  , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])+  , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])   } deriving (Show)  -- |@@ -219,3 +219,18 @@                        , (primName "String"   , (Star, ExternData))                        , (primName "Number"   , (Star, ExternData))                        , (primName "Boolean"  , (Star, ExternData)) ]++-- |+-- Finds information about data constructors from the current environment.+--+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)+lookupConstructor env ctor =+  fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env++-- |+-- Checks whether a data constructor is for a newtype.+--+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool+isNewtypeConstructor e ctor = case lookupConstructor e ctor of+  (Newtype, _, _) -> True+  (Data, _, _) -> False

@@ -64,9 +64,6 @@   forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs   forTypes _ = [] -getModuleName :: Module -> ModuleName-getModuleName (Module mn _ _) = mn- -- | -- Convert a strongly connected component of the module graph to a module --

@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}  module Language.PureScript.Names where @@ -71,7 +71,7 @@ -- | -- A qualified name, i.e. a name with an optional module name ---data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor)  instance (Show a) => Show (Qualified a) where   show (Qualified Nothing a) = show a

@@ -1,76 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimizer--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module optimizes code in the simplified-Javascript intermediate representation.------ The following optimizations are supported:------  * Collapsing nested blocks------  * Tail call elimination------  * Inlining of (>>=) and ret for the Eff monad------  * Removal of unnecessary thunks------  * Eta conversion------  * Inlining variables------  * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)------  * Inlining primitive Javascript operators-----------------------------------------------------------------------------------module Language.PureScript.Optimizer (-    optimize-) where--import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.Options-import qualified Language.PureScript.Constants as C--import Language.PureScript.Optimizer.Common-import Language.PureScript.Optimizer.TCO-import Language.PureScript.Optimizer.MagicDo-import Language.PureScript.Optimizer.Inliner-import Language.PureScript.Optimizer.Unused-import Language.PureScript.Optimizer.Blocks---- |--- Apply a series of optimizer passes to simplified Javascript code----optimize :: Options mode -> JS -> JS-optimize opts | optionsNoOptimizations opts = id-              | otherwise = untilFixedPoint (applyAll-  [ collapseNestedBlocks-  , collapseNestedIfs-  , tco opts-  , magicDo opts-  , removeCodeAfterReturnStatements-  , removeUnusedArg-  , removeUndefinedApp-  , unThunk-  , etaConvert-  , evaluateIifes-  , inlineVariables-  , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]-  , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]-  , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer-  , inlineCommonOperators ])--untilFixedPoint :: (Eq a) => (a -> a) -> a -> a-untilFixedPoint f = go-  where-  go a = let a' = f a in-          if a' == a then a' else go a'-

@@ -1,42 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimizer.Blocks--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Optimizer steps for simplifying Javascript blocks-----------------------------------------------------------------------------------module Language.PureScript.Optimizer.Blocks-  ( collapseNestedBlocks-  , collapseNestedIfs-  ) where--import Language.PureScript.CodeGen.JS.AST---- |--- Collapse blocks which appear nested directly below another block----collapseNestedBlocks :: JS -> JS-collapseNestedBlocks = everywhereOnJS collapse-  where-  collapse :: JS -> JS-  collapse (JSBlock sts) = JSBlock (concatMap go sts)-  collapse js = js-  go :: JS -> [JS]-  go (JSBlock sts) = sts-  go s = [s]--collapseNestedIfs :: JS -> JS-collapseNestedIfs = everywhereOnJS collapse-  where-  collapse :: JS -> JS-  collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =-      JSIfElse (JSBinary And cond1 cond2) body Nothing-  collapse js = js

@@ -1,77 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimizer.Common--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Common functions used by the various optimizer phases-----------------------------------------------------------------------------------module Language.PureScript.Optimizer.Common where--import Data.Maybe (fromMaybe)--import Language.PureScript.CodeGen.JS.AST--applyAll :: [a -> a] -> a -> a-applyAll = foldl1 (.)--replaceIdent :: String -> JS -> JS -> JS-replaceIdent var1 js = everywhereOnJS replace-  where-  replace (JSVar var2) | var1 == var2 = js-  replace other = other--replaceIdents :: [(String, JS)] -> JS -> JS-replaceIdents vars = everywhereOnJS replace-  where-  replace v@(JSVar var) = fromMaybe v $ lookup var vars-  replace other = other--isReassigned :: String -> JS -> Bool-isReassigned var1 = everythingOnJS (||) check-  where-  check :: JS -> Bool-  check (JSFunction _ args _) | var1 `elem` args = True-  check (JSVariableIntroduction arg _) | var1 == arg = True-  check (JSAssignment (JSVar arg) _) | var1 == arg = True-  check (JSFor arg _ _ _) | var1 == arg = True-  check (JSForIn arg _ _) | var1 == arg = True-  check _ = False--isRebound :: JS -> JS -> Bool-isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)-  where-  variablesOf (JSVar var) = [var]-  variablesOf _ = []--isUsed :: String -> JS -> Bool-isUsed var1 = everythingOnJS (||) check-  where-  check :: JS -> Bool-  check (JSVar var2) | var1 == var2 = True-  check (JSAssignment target _) | var1 == targetVariable target = True-  check _ = False--targetVariable :: JS -> String-targetVariable (JSVar var) = var-targetVariable (JSAccessor _ tgt) = targetVariable tgt-targetVariable (JSIndexer _ tgt) = targetVariable tgt-targetVariable _ = error "Invalid argument to targetVariable"--isUpdated :: String -> JS -> Bool-isUpdated var1 = everythingOnJS (||) check-  where-  check :: JS -> Bool-  check (JSAssignment target _) | var1 == targetVariable target = True-  check _ = False--removeFromBlock :: ([JS] -> [JS]) -> JS -> JS-removeFromBlock go (JSBlock sts) = JSBlock (go sts)-removeFromBlock _  js = js

@@ -1,192 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimizer.Inliner--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module provides basic inlining capabilities-----------------------------------------------------------------------------------module Language.PureScript.Optimizer.Inliner (-  inlineVariables,-  inlineOperator,-  inlineCommonOperators,-  etaConvert,-  unThunk,-  evaluateIifes-) where--import Data.Maybe (fromMaybe)--import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.CodeGen.Common (identToJs)-import Language.PureScript.Optimizer.Common-import Language.PureScript.Names--import qualified Language.PureScript.Constants as C--shouldInline :: JS -> Bool-shouldInline (JSVar _) = True-shouldInline (JSNumericLiteral _) = True-shouldInline (JSStringLiteral _) = True-shouldInline (JSBooleanLiteral _) = True-shouldInline (JSAccessor _ val) = shouldInline val-shouldInline (JSIndexer index val) = shouldInline index && shouldInline val-shouldInline _ = False--etaConvert :: JS -> JS-etaConvert = everywhereOnJS convert-  where-  convert :: JS -> JS-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])-    | all shouldInline args &&-      not (any (`isRebound` block) (map JSVar idents)) &&-      not (any (`isRebound` block) args)-      = JSBlock (map (replaceIdents (zip idents args)) body)-  convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn-  convert js = js--unThunk :: JS -> JS-unThunk = everywhereOnJS convert-  where-  convert :: JS -> JS-  convert (JSBlock []) = JSBlock []-  convert (JSBlock jss) =-    case last jss of-      JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body-      _ -> JSBlock jss-  convert js = js--evaluateIifes :: JS -> JS-evaluateIifes = everywhereOnJS convert-  where-  convert :: JS -> JS-  convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret-  convert js = js--inlineVariables :: JS -> JS-inlineVariables = everywhereOnJS $ removeFromBlock go-  where-  go :: [JS] -> [JS]-  go [] = []-  go (JSVariableIntroduction var (Just js) : sts)-    | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =-      go (map (replaceIdent var js) sts)-  go (s:sts) = s : go sts--inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS-inlineOperator (m, op) f = everywhereOnJS convert-  where-  convert :: JS -> JS-  convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y-  convert other = other-  isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)-  isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'-  isOp _ = False--inlineCommonOperators :: JS -> JS-inlineCommonOperators = applyAll $-  [ binary C.numNumber (C.+) Add-  , binary C.numNumber (C.-) Subtract-  , binary C.numNumber (C.*) Multiply-  , binary C.numNumber (C./) Divide-  , binary C.numNumber (C.%) Modulus-  , unary  C.numNumber C.negate Negate--  , binary C.ordNumber (C.<) LessThan-  , binary C.ordNumber (C.>) GreaterThan-  , binary C.ordNumber (C.<=) LessThanOrEqualTo-  , binary C.ordNumber (C.>=) GreaterThanOrEqualTo--  , binary C.eqNumber (C.==) EqualTo-  , binary C.eqNumber (C./=) NotEqualTo-  , binary C.eqString (C.==) EqualTo-  , binary C.eqString (C./=) NotEqualTo-  , binary C.eqBoolean (C.==) EqualTo-  , binary C.eqBoolean (C./=) NotEqualTo--  , binary C.semigroupString (C.<>) Add-  , binary C.semigroupString (C.++) Add--  , binaryFunction C.bitsNumber C.shl ShiftLeft-  , binaryFunction C.bitsNumber C.shr ShiftRight-  , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight-  , binary         C.bitsNumber (C..&.) BitwiseAnd-  , binary         C.bitsNumber (C..|.) BitwiseOr-  , binary         C.bitsNumber (C..^.) BitwiseXor-  , unary          C.bitsNumber C.complement BitwiseNot--  , binary C.boolLikeBoolean (C.&&) And-  , binary C.boolLikeBoolean (C.||) Or-  , unary  C.boolLikeBoolean C.not Not-  ] ++-  [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]-  where-  binary :: String -> String -> BinaryOperator -> JS -> JS-  binary dictName opString op = everywhereOnJS convert-    where-    convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y-    convert other = other-    isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)-    isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'-    isOp _ = False-  binaryFunction :: String -> String -> BinaryOperator -> JS -> JS-  binaryFunction dictName fnName op = everywhereOnJS convert-    where-    convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y-    convert other = other-    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'-    isOp _ = False-  unary :: String -> String -> UnaryOperator -> JS -> JS-  unary dictName fnName op = everywhereOnJS convert-    where-    convert :: JS -> JS-    convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x-    convert other = other-    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName-    isOp _ = False-  isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName-  isOpDict _ _ = False-  mkFn :: Int -> JS -> JS-  mkFn 0 = everywhereOnJS convert-    where-    convert :: JS -> JS-    convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =-      JSFunction Nothing [] (JSBlock js)-    convert other = other-  mkFn n = everywhereOnJS convert-    where-    convert :: JS -> JS-    convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =-      case collectArgs n [] fn of-        Just (args, js) -> JSFunction Nothing args (JSBlock js)-        Nothing -> orig-    convert other = other-    collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])-    collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)-    collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret-    collectArgs _ _   _ = Nothing--  isNFn :: String -> Int -> JS -> Bool-  isNFn prefix n (JSVar name) = name == (prefix ++ show n)-  isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)-  isNFn _ _ _ = False--  runFn :: Int -> JS -> JS-  runFn n = everywhereOnJS convert-    where-    convert :: JS -> JS-    convert js = fromMaybe js $ go n [] js--    go :: Int -> [JS] -> JS -> Maybe JS-    go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)-    go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs-    go _ _   _ = Nothing

@@ -1,162 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimizer.MagicDo--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module implements the "Magic Do" optimization, which inlines calls to return--- and bind for the Eff monad, as well as some of its actions.-----------------------------------------------------------------------------------module Language.PureScript.Optimizer.MagicDo (-  magicDo-) where--import Data.List (nub)-import Data.Maybe (fromJust, isJust)--import Language.PureScript.Options-import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.CodeGen.Common (identToJs)-import Language.PureScript.Names--import qualified Language.PureScript.Constants as C--magicDo :: Options mode -> JS -> JS-magicDo opts | optionsNoMagicDo opts = id-             | otherwise = inlineST . magicDo'---- |--- Inline type class dictionaries for >>= and return for the Eff monad------ E.g.------  Prelude[">>="](dict)(m1)(function(x) {---    return ...;---  })------ becomes------  function __do {---    var x = m1();---    ...---  }----magicDo' :: JS -> JS-magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert-  where-  -- The name of the function block which is added to denote a do block-  fnName = "__do"-  -- Desugar monomorphic calls to >>= and return for the Eff monad-  convert :: JS -> JS-  -- Desugar return-  convert (JSApp (JSApp ret [val]) []) | isReturn ret = val-  -- Desugar pure-  convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val-  -- Desugar >>-  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind && isJSReturn (last js) =-    let JSReturn ret = last js in-    JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )-  -- Desugar >>=-  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) =-    let JSReturn ret = last js in-    JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] )-  -- Desugar untilE-  convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =-    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []-  -- Desugar whileE-  convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =-    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []-  convert other = other-  -- Check if an expression represents a monomorphic call to >>= for the Eff monad-  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True-  isBind _ = False-  -- Check if an expression represents a monomorphic call to return for the Eff monad-  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True-  isReturn _ = False-  -- Check if an expression represents a monomorphic call to pure for the Eff applicative-  isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True-  isPure _ = False-  -- Check if an expression represents the polymorphic >>= function-  isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))-  isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)-  isBindPoly _ = False-  -- Check if an expression represents the polymorphic return function-  isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped-  isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return-  isRetPoly _ = False-  -- Check if an expression represents the polymorphic pure function-  isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'-  isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'-  isPurePoly _ = False-  -- Check if an expression represents a function in the Ef module-  isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'-  isEffFunc _ _ = False-  -- Check if an expression represents the Monad Eff dictionary-  isEffDict name (JSVar ident) | ident == name = True-  isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name-  isEffDict _ _ = False-  -- Remove __do function applications which remain after desugaring-  undo :: JS -> JS-  undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body-  undo other = other--  isJSReturn (JSReturn _) = True-  isJSReturn _ = False---- |--- Inline functions in the ST module----inlineST :: JS -> JS-inlineST = everywhereOnJS convertBlock-  where-  -- Look for runST blocks and inline the STRefs there.-  -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then-  -- we can be more aggressive about inlining, and actually turn STRefs into local variables.-  convertBlock (JSApp f [arg]) | isSTFunc C.runST f =-    let refs = nub . findSTRefsIn $ arg-        usages = findAllSTUsagesIn arg-        allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages-        localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs-    in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg-  convertBlock other = other-  -- Convert a block in a safe way, preserving object wrappers of references,-  -- or in a more aggressive way, turning wrappers into local variables depending on the-  -- agg(ressive) parameter.-  convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =-   JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])-  convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =-    if agg then ref else JSAccessor C.stRefValue ref-  convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =-    if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg-  convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =-    if agg then JSAssignment ref (JSApp func [ref]) else  JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])-  convert _ other = other-  -- Check if an expression represents a function in the ST module-  isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'-  isSTFunc _ _ = False-  -- Find all ST Refs initialized in this block-  findSTRefsIn = everythingOnJS (++) isSTRef-    where-    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]-    isSTRef _ = []-  -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef-  findAllSTUsagesIn = everythingOnJS (++) isSTUsage-    where-    isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]-    isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]-    isSTUsage _ = []-  -- Find all uses of a variable-  appearingIn ref = everythingOnJS (++) isVar-    where-    isVar e@(JSVar v) | v == ref = [e]-    isVar _ = []-  -- Convert a JS value to a String if it is a JSVar-  toVar (JSVar v) = Just v-  toVar _ = Nothing

@@ -1,103 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimizer.TCO--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module implements tail call elimination.-----------------------------------------------------------------------------------module Language.PureScript.Optimizer.TCO (tco) where--import Language.PureScript.Options-import Language.PureScript.CodeGen.JS.AST---- |--- Eliminate tail calls----tco :: Options mode -> JS -> JS-tco opts | optionsNoTco opts = id-         | otherwise = tco'--tco' :: JS -> JS-tco' = everywhereOnJS convert-  where-  tcoLabel :: String-  tcoLabel = "tco"-  tcoVar :: String -> String-  tcoVar arg = "__tco_" ++ arg-  copyVar :: String -> String-  copyVar arg = "__copy_" ++ arg-  convert :: JS -> JS-  convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =-    let-      (argss, body', replace) = collectAllFunctionArgs [] id fn-    in case () of-      _ | isTailCall name body' ->-            let-              allArgs = concat $ reverse argss-            in-              JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))-        | otherwise -> js-  convert js = js-  collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)-  collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =-    collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body-  collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =-    (args : allArgs, body, f . JSFunction ident (map copyVar args))-  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =-    collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body-  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =-    (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))-  collectAllFunctionArgs allArgs f body = (allArgs, body, f)-  isTailCall :: String -> JS -> Bool-  isTailCall ident js =-    let-      numSelfCalls = everythingOnJS (+) countSelfCalls js-      numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js-      numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js-    in-      numSelfCalls > 0-      && numSelfCalls == numSelfCallsInTailPosition-      && numSelfCallsUnderFunctions == 0-    where-    countSelfCalls :: JS -> Int-    countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1-    countSelfCalls _ = 0-    countSelfCallsInTailPosition :: JS -> Int-    countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1-    countSelfCallsInTailPosition _ = 0-    countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'-    countSelfCallsUnderFunctions _ = 0-  toLoop :: String -> [String] -> JS -> JS-  toLoop ident allArgs js = JSBlock $-        map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++-        [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]-    where-    loopify :: JS -> JS-    loopify (JSReturn ret) | isSelfCall ident ret =-      let-        allArgumentValues = concat $ collectSelfCallArgs [] ret-      in-        JSBlock $ zipWith (\val arg ->-                    JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs-                  ++ map (\arg ->-                    JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs-                  ++ [ JSContinue tcoLabel ]-    loopify other = other-    collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]-    collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn-    collectSelfCallArgs allArgumentValues _ = allArgumentValues-  isSelfCall :: String -> JS -> Bool-  isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True-  isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn-  isSelfCall _ _ = False-  isFunction :: JS -> Bool-  isFunction (JSFunction _ _ _) = True-  isFunction _ = False

@@ -1,46 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimizer.Unused--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Removes unused variables-----------------------------------------------------------------------------------module Language.PureScript.Optimizer.Unused-  ( removeCodeAfterReturnStatements-  , removeUnusedArg-  , removeUndefinedApp-  ) where--import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.Optimizer.Common--import qualified Language.PureScript.Constants as C--removeCodeAfterReturnStatements :: JS -> JS-removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)-  where-  go :: [JS] -> [JS]-  go jss | not (any isJSReturn jss) = jss-         | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]-  isJSReturn (JSReturn _) = True-  isJSReturn _ = False--removeUnusedArg :: JS -> JS-removeUnusedArg = everywhereOnJS convert-  where-  convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body-  convert js = js--removeUndefinedApp :: JS -> JS-removeUndefinedApp = everywhereOnJS convert-  where-  convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []-  convert js = js

@@ -31,4 +31,5 @@ import Language.PureScript.Parser.Types as P import Language.PureScript.Parser.State as P import Language.PureScript.Parser.Kinds as P+import Language.PureScript.Parser.Lexer as P import Language.PureScript.Parser.Declarations as P

@@ -17,299 +17,47 @@  module Language.PureScript.Parser.Common where -import Data.Functor.Identity import Control.Applicative-import Control.Monad-import Language.PureScript.Parser.State-import qualified Text.Parsec as P-import qualified Text.Parsec.Token as PT+import Control.Monad (guard) +import Language.PureScript.Comments+import Language.PureScript.Parser.Lexer+import Language.PureScript.Parser.State import Language.PureScript.Names --- |--- A list of purescript reserved identifiers----reservedPsNames :: [String]-reservedPsNames = [ "data"-                  , "newtype"-                  , "type"-                  , "foreign"-                  , "import"-                  , "infixl"-                  , "infixr"-                  , "infix"-                  , "class"-                  , "instance"-                  , "module"-                  , "case"-                  , "of"-                  , "if"-                  , "then"-                  , "else"-                  , "do"-                  , "let"-                  , "true"-                  , "false"-                  , "in"-                  , "where"-                  ]---- |--- The characters allowed for use in operators----opChars :: [Char]-opChars = ":!#$%&*+./<=>?@\\^|-~"---- |--- A list of reserved identifiers for types----reservedTypeNames :: [String]-reservedTypeNames = [ "forall"-                    , "where" ]---- |--- A list of reserved operators----reservedOpNames :: [String]-reservedOpNames = [ "=>", "->", "=", ".", "\\", "|" ]---- |--- Valid first characters for an identifier----identStart :: P.Parsec String u Char-identStart = P.lower <|> P.oneOf "_"---- |--- Valid identifier characters----identLetter :: P.Parsec String u Char-identLetter = P.alphaNum <|> P.oneOf "_'"---- |--- Valid first characters for an operator----opStart :: P.Parsec String u Char-opStart = P.oneOf opChars---- |--- Valid operators characters----opLetter :: P.Parsec String u Char-opLetter = P.oneOf opChars---- |--- The PureScript language definition----langDef :: PT.GenLanguageDef String u Identity-langDef = PT.LanguageDef-  { PT.reservedNames   = reservedPsNames-  , PT.reservedOpNames = reservedOpNames-  , PT.commentStart    = "{-"-  , PT.commentEnd      = "-}"-  , PT.commentLine     = "--"-  , PT.nestedComments  = True-  , PT.identStart      = identStart-  , PT.identLetter     = identLetter-  , PT.opStart         = opStart-  , PT.opLetter        = opLetter-  , PT.caseSensitive   = True-  }---- |--- A token parser based on the language definition----tokenParser :: PT.GenTokenParser String u Identity-tokenParser = PT.makeTokenParser langDef---- |--- Parse a token----lexeme :: P.Parsec String u a -> P.Parsec String u a-lexeme = PT.lexeme tokenParser---- |--- Parse an identifier----identifier :: P.Parsec String u String-identifier = PT.identifier tokenParser---- |--- Parse an identifier in a more permissive position----identifierName :: P.Parsec String u String-identifierName = lexeme $ (:) <$> identStart <*> many identLetter---- |--- Parse a reserved word----reserved :: String -> P.Parsec String u ()-reserved = PT.reserved tokenParser---- |--- Parse a reserved operator----reservedOp :: String -> P.Parsec String u ()-reservedOp = PT.reservedOp tokenParser---- |--- Parse an operator----operator :: P.Parsec String u String-operator = PT.operator tokenParser---- |--- Parse a string literal----stringLiteral :: P.Parsec String u String-stringLiteral = lexeme blockString <|> PT.stringLiteral tokenParser-  where delimeter   = P.try (P.string "\"\"\"")-        blockString = delimeter >> P.manyTill P.anyChar delimeter---- |--- Parse whitespace----whiteSpace :: P.Parsec String u ()-whiteSpace = PT.whiteSpace tokenParser---- |--- Semicolon----semi :: P.Parsec String u String-semi = PT.semi tokenParser---- |--- Colon----colon :: P.Parsec String u String-colon = PT.colon tokenParser---- |--- Period----dot :: P.Parsec String u String-dot = PT.dot tokenParser---- |--- Comma----comma :: P.Parsec String u String-comma = PT.comma tokenParser---- |--- Backtick----tick :: P.Parsec String u Char-tick = lexeme $ P.char '`'---- |--- Pipe character----pipe :: P.Parsec String u Char-pipe = lexeme $ P.char '|'---- |--- Natural number----natural :: P.Parsec String u Integer-natural = PT.natural tokenParser+import qualified Text.Parsec as P --- |--- Parse a proper name----properName :: P.Parsec String u ProperName-properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")+properName :: TokenParser ProperName+properName = ProperName <$> uname  -- | -- Parse a module name ---moduleName :: P.Parsec String ParseState ModuleName-moduleName = ModuleName <$> P.try (sepBy properName dot)+moduleName :: TokenParser ModuleName+moduleName = part []+  where+  part path = (do name <- ProperName <$> P.try qualifier+                  part (path `snoc` name))+              <|> (ModuleName . snoc path . ProperName <$> mname)+  snoc path name = path ++ [name]  -- | -- Parse a qualified name, i.e. M.name or just name ---parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)+parseQualified :: TokenParser a -> TokenParser (Qualified a) parseQualified parser = part []   where-  part path = (do name <- P.try (properName <* delimiter)+  part path = (do name <- ProperName <$> P.try qualifier                   part (updatePath path name))               <|> (Qualified (qual path) <$> P.try parser)-  delimiter = indented *> dot <* P.notFollowedBy dot   updatePath path name = path ++ [name]   qual path = if null path then Nothing else Just $ ModuleName path  -- |--- Parse an integer or floating point value----integerOrFloat :: P.Parsec String u (Either Integer Double)-integerOrFloat = (Right <$> P.try (PT.float tokenParser) <|>-                  Left <$> P.try (PT.natural tokenParser)) P.<?> "number"---- | -- Parse an identifier or parenthesized operator ---parseIdent :: P.Parsec String ParseState Ident-parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)---- |--- Parse a token inside square brackets----squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a-squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)---- |--- Parse a token inside parentheses----parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a-parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)---- |--- Parse a token inside braces----braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a-braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)---- |--- Parse a token inside angle brackets----angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a-angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)---- |--- Parse zero or more values separated by a separator token----sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]-sepBy p s = P.sepBy (indented *> p) (indented *> s)---- |--- Parse one or more values separated by a separator token----sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]-sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)---- |--- Parse zero or more values separated by semicolons----semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]-semiSep = flip sepBy semi---- |--- Parse one or more values separated by semicolons----semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]-semiSep1 = flip sepBy1 semi---- |--- Parse zero or more values separated by commas----commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]-commaSep = flip sepBy comma---- |--- Parse one or more values separated by commas----commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]-commaSep1 = flip sepBy1 comma+parseIdent :: TokenParser Ident+parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol)  -- | -- Run the first parser, then match the second if possible, applying the specified function on a successful match@@ -343,13 +91,13 @@ -- | -- Parse an identifier in backticks or an operator ---parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)-parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> operator))+parseIdentInfix :: TokenParser (Qualified Ident)+parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> symbol))  -- | -- Mark the current indentation level ---mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a+mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a mark p = do   current <- indentationLevel <$> P.getState   pos <- P.sourceColumn <$> P.getPosition@@ -361,7 +109,7 @@ -- | -- Check that the current identation level matches a predicate ---checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState () checkIndentation rel = do   col <- P.sourceColumn <$> P.getPosition   current <- indentationLevel <$> P.getState@@ -370,18 +118,23 @@ -- | -- Check that the current indentation level is past the current mark ---indented :: P.Parsec String ParseState ()+indented :: P.Parsec s ParseState () indented = checkIndentation (>) P.<?> "indentation"  -- | -- Check that the current indentation level is at the same indentation as the current mark ---same :: P.Parsec String ParseState ()+same :: P.Parsec s ParseState () same = checkIndentation (==) P.<?> "no indentation"  -- |--- Run a parser which supports indentation+-- Read the comments from the the next token, without consuming it ---runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a-runIndentParser filePath p = P.runParser p (ParseState 0) filePath+readComments :: P.Parsec [PositionedToken] u [Comment]+readComments = P.lookAhead $ ptComments <$> P.anyToken +-- |+-- Run a parser+--+runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a+runTokenParser filePath p = P.runParser p (ParseState 0) filePath

@@ -26,6 +26,8 @@     parseBinderNoParens, ) where +import Prelude hiding (lex)+ import Data.Maybe (isJust, fromMaybe) import Data.Traversable (forM) @@ -33,11 +35,12 @@ import Control.Arrow ((+++))  import Language.PureScript.Kinds-import Language.PureScript.Parser.State-import Language.PureScript.Parser.Common import Language.PureScript.AST+import Language.PureScript.Comments+import Language.PureScript.Parser.Common import Language.PureScript.Parser.Types import Language.PureScript.Parser.Kinds+import Language.PureScript.Parser.Lexer import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Environment @@ -48,53 +51,54 @@ -- | -- Read source position information ---withSourceSpan :: (SourceSpan -> a -> a) -> P.Parsec s u a -> P.Parsec s u a+withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a withSourceSpan f p = do   start <- P.getPosition+  comments <- C.readComments   x <- p   end <- P.getPosition   let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)-  return $ f sp x+  return $ f sp comments x   where   toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos) -kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)+kindedIdent :: TokenParser (String, Maybe Kind) kindedIdent = (, Nothing) <$> identifier-          <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind)))+          <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) -parseDataDeclaration :: P.Parsec String ParseState Declaration+parseDataDeclaration :: TokenParser Declaration parseDataDeclaration = do   dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)   name <- indented *> properName   tyArgs <- many (indented *> kindedIdent)   ctors <- P.option [] $ do-    _ <- lexeme $ indented *> P.char '='-    sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe+    indented *> equals+    P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe   return $ DataDeclaration dtype name tyArgs ctors -parseTypeDeclaration :: P.Parsec String ParseState Declaration+parseTypeDeclaration :: TokenParser Declaration parseTypeDeclaration =-  TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))+  TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon)                   <*> parsePolyType -parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration+parseTypeSynonymDeclaration :: TokenParser Declaration parseTypeSynonymDeclaration =   TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)                          <*> many (indented *> kindedIdent)-                         <*> (lexeme (indented *> P.char '=') *> noWildcards parsePolyType)+                         <*> (indented *> equals *> noWildcards parsePolyType) -parseValueDeclaration :: P.Parsec String ParseState Declaration+parseValueDeclaration :: TokenParser Declaration parseValueDeclaration = do   name <- parseIdent   binders <- P.many parseBinderNoParens   value <- Left <$> (C.indented *>                        P.many1 ((,) <$> parseGuard-                                    <*> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)+                                    <*> (indented *> equals *> parseValueWithWhereClause)                                ))-       <|> Right <$> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)+       <|> Right <$> (indented *> equals *> parseValueWithWhereClause)   return $ ValueDeclaration name Value binders value   where-  parseValueWithWhereClause :: P.Parsec String ParseState Expr+  parseValueWithWhereClause :: TokenParser Expr   parseValueWithWhereClause = do     value <- parseValue     whereClause <- P.optionMaybe $ do@@ -104,42 +108,42 @@       C.mark $ P.many1 (C.same *> parseLocalDeclaration)     return $ maybe value (`Let` value) whereClause -parseExternDeclaration :: P.Parsec String ParseState Declaration+parseExternDeclaration :: TokenParser Declaration parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>    (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)-                          <*> (lexeme (indented *> P.string "::") *> parseKind)+                          <*> (indented *> doubleColon *> parseKind)    <|> (do reserved "instance"-           name <- parseIdent <* lexeme (indented *> P.string "::")+           name <- parseIdent <* indented <* doubleColon            deps <- P.option [] $ do              deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))              indented-             reservedOp "=>"+             rfatArrow              return deps            className <- indented *> parseQualified properName            tys <- P.many (indented *> noWildcards parseTypeAtom)            return $ ExternInstanceDeclaration name deps className tys)    <|> (do ident <- parseIdent            js <- P.optionMaybe (JSRaw <$> stringLiteral)-           ty <- lexeme (indented *> P.string "::") *> noWildcards parsePolyType+           ty <- indented *> doubleColon *> noWildcards parsePolyType            return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)) -parseAssociativity :: P.Parsec String ParseState Associativity+parseAssociativity :: TokenParser Associativity parseAssociativity =   (P.try (reserved "infixl") >> return Infixl) <|>   (P.try (reserved "infixr") >> return Infixr) <|>   (P.try (reserved "infix") >>  return Infix) -parseFixity :: P.Parsec String ParseState Fixity+parseFixity :: TokenParser Fixity parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural) -parseFixityDeclaration :: P.Parsec String ParseState Declaration+parseFixityDeclaration :: TokenParser Declaration parseFixityDeclaration = do   fixity <- parseFixity   indented-  name <- operator+  name <- symbol   return $ FixityDeclaration fixity name -parseImportDeclaration :: P.Parsec String ParseState Declaration+parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do   reserved "import"   indented@@ -169,20 +173,20 @@     return $ fromMaybe Unqualified (expectedType <$> idents)  -parseDeclarationRef :: P.Parsec String ParseState DeclarationRef+parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = withSourceSpan PositionedDeclarationRef $   ValueRef <$> parseIdent     <|> do name <- properName-           dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)+           dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)            return $ maybe (TypeClassRef name) (TypeRef name) dctors -parseTypeClassDeclaration :: P.Parsec String ParseState Declaration+parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do   reserved "class"   implies <- P.option [] $ do     indented     implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))-    reservedOp "<="+    lfatArrow     return implies   className <- indented *> properName   idents <- P.many (indented *> kindedIdent)@@ -191,14 +195,14 @@     mark (P.many (same *> positioned parseTypeDeclaration))   return $ TypeClassDeclaration className idents implies members -parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration+parseTypeInstanceDeclaration :: TokenParser Declaration parseTypeInstanceDeclaration = do   reserved "instance"-  name <- parseIdent <* lexeme (indented *> P.string "::")+  name <- parseIdent <* indented <* doubleColon   deps <- P.optionMaybe $ do     deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))     indented-    reservedOp "=>"+    rfatArrow     return deps   className <- indented *> parseQualified properName   ty <- P.many (indented *> (noWildcards parseTypeAtom))@@ -207,13 +211,13 @@     mark (P.many (same *> positioned parseValueDeclaration))   return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members -positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration+positioned :: TokenParser Declaration -> TokenParser Declaration positioned d = withSourceSpan PositionedDeclaration d  -- | -- Parse a single declaration ---parseDeclaration :: P.Parsec String ParseState Declaration+parseDeclaration :: TokenParser Declaration parseDeclaration = positioned (P.choice                    [ parseDataDeclaration                    , parseTypeDeclaration@@ -226,7 +230,7 @@                    , parseTypeInstanceDeclaration                    ]) P.<?> "declaration" -parseLocalDeclaration :: P.Parsec String ParseState Declaration+parseLocalDeclaration :: TokenParser Declaration parseLocalDeclaration = positioned (P.choice                    [ parseTypeDeclaration                    , parseValueDeclaration@@ -235,13 +239,13 @@ -- | -- Parse a module header and a collection of declarations ---parseModule :: P.Parsec String ParseState Module+parseModule :: TokenParser Module parseModule = do   reserved "module"   indented   name <- moduleName   exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef-  _ <- lexeme $ P.string "where"+  reserved "where"   decls <- mark (P.many (same *> parseDeclaration))   return $ Module name decls exports @@ -250,9 +254,11 @@ -- parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)] parseModulesFromFiles toFilePath input =-  fmap collect . forM input $ \(filename, content) -> do-    ms <- runIndentParser (toFilePath filename) parseModules content-    return (filename, ms)+  fmap collect . forM input $ \(k, content) -> do+    let filename = toFilePath k+    ts <- lex filename content+    ms <- runTokenParser filename parseModules ts+    return (k, ms)   where   collect :: [(k, [v])] -> [(k, v)]   collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]@@ -260,77 +266,77 @@ -- | -- Parse a collection of modules ---parseModules :: P.Parsec String ParseState [Module]-parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof+parseModules :: TokenParser [Module]+parseModules = mark (P.many (same *> parseModule)) <* P.eof -booleanLiteral :: P.Parsec String ParseState Bool-booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)+booleanLiteral :: TokenParser Bool+booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False) -parseNumericLiteral :: P.Parsec String ParseState Expr-parseNumericLiteral = NumericLiteral <$> C.integerOrFloat+parseNumericLiteral :: TokenParser Expr+parseNumericLiteral = NumericLiteral <$> number -parseStringLiteral :: P.Parsec String ParseState Expr-parseStringLiteral = StringLiteral <$> C.stringLiteral+parseStringLiteral :: TokenParser Expr+parseStringLiteral = StringLiteral <$> stringLiteral -parseBooleanLiteral :: P.Parsec String ParseState Expr+parseBooleanLiteral :: TokenParser Expr parseBooleanLiteral = BooleanLiteral <$> booleanLiteral -parseArrayLiteral :: P.Parsec String ParseState Expr-parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)+parseArrayLiteral :: TokenParser Expr+parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue) -parseObjectLiteral :: P.Parsec String ParseState Expr-parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)+parseObjectLiteral :: TokenParser Expr+parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue) -parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr)-parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifierName <|> C.stringLiteral) <* C.indented <* C.colon)+parseIdentifierAndValue :: TokenParser (String, Expr)+parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)                               <*> (C.indented *> parseValue) -parseAbs :: P.Parsec String ParseState Expr+parseAbs :: TokenParser Expr parseAbs = do-  C.reservedOp "\\"+  symbol' "\\"   args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))-  C.indented *> C.reservedOp "->"+  C.indented *> rarrow   value <- parseValue   return $ toFunction args value   where   toFunction :: [Expr -> Expr] -> Expr -> Expr   toFunction args value = foldr ($) value args -parseVar :: P.Parsec String ParseState Expr+parseVar :: TokenParser Expr parseVar = Var <$> C.parseQualified C.parseIdent -parseConstructor :: P.Parsec String ParseState Expr+parseConstructor :: TokenParser Expr parseConstructor = Constructor <$> C.parseQualified C.properName -parseCase :: P.Parsec String ParseState Expr-parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)+parseCase :: TokenParser Expr+parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)                  <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative))) -parseCaseAlternative :: P.Parsec String ParseState CaseAlternative+parseCaseAlternative :: TokenParser CaseAlternative parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)                                        <*> (Left <$> (C.indented *>                                                         P.many1 ((,) <$> parseGuard-                                                                     <*> (lexeme (indented *> C.reservedOp "->") *> parseValue)+                                                                     <*> (indented *> rarrow *> parseValue)                                                                 ))-                                            <|> Right <$> (lexeme (indented *> C.reservedOp "->") *> parseValue))+                                            <|> Right <$> (indented *> rarrow *> parseValue))                                        P.<?> "case alternative" -parseIfThenElse :: P.Parsec String ParseState Expr-parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)-                             <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)-                             <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)+parseIfThenElse :: TokenParser Expr+parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)+                             <*> (C.indented *> reserved "then" *> C.indented *> parseValue)+                             <*> (C.indented *> reserved "else" *> C.indented *> parseValue) -parseLet :: P.Parsec String ParseState Expr+parseLet :: TokenParser Expr parseLet = do-  C.reserved "let"+  reserved "let"   C.indented   ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)   C.indented-  C.reserved "in"+  reserved "in"   result <- parseValue   return $ Let ds result -parseValueAtom :: P.Parsec String ParseState Expr+parseValueAtom :: TokenParser Expr parseValueAtom = P.choice             [ P.try parseNumericLiteral             , P.try parseStringLiteral@@ -344,32 +350,32 @@             , parseIfThenElse             , parseDo             , parseLet-            , Parens <$> C.parens parseValue ]+            , Parens <$> parens parseValue ] -parsePropertyUpdate :: P.Parsec String ParseState (String, Expr)+parsePropertyUpdate :: TokenParser (String, Expr) parsePropertyUpdate = do-  name <- C.lexeme (C.identifierName <|> C.stringLiteral)-  _ <- C.lexeme $ C.indented *> P.char '='+  name <- lname <|> stringLiteral+  _ <- C.indented *> equals   value <- C.indented *> parseValue   return (name, value) -parseAccessor :: Expr -> P.Parsec String ParseState Expr+parseAccessor :: Expr -> TokenParser Expr parseAccessor (Constructor _) = P.unexpected "constructor"-parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifierName <|> C.stringLiteral)) <*> pure obj+parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj -parseDo :: P.Parsec String ParseState Expr+parseDo :: TokenParser Expr parseDo = do-  C.reserved "do"+  reserved "do"   C.indented   Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement)) -parseDoNotationLet :: P.Parsec String ParseState DoNotationElement-parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))+parseDoNotationLet :: TokenParser DoNotationElement+parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration))) -parseDoNotationBind :: P.Parsec String ParseState DoNotationElement-parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)+parseDoNotationBind :: TokenParser DoNotationElement+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue) -parseDoNotationElement :: P.Parsec String ParseState DoNotationElement+parseDoNotationElement :: TokenParser DoNotationElement parseDoNotationElement = P.choice             [ P.try parseDoNotationBind             , parseDoNotationLet@@ -378,7 +384,7 @@ -- | -- Parse a value ---parseValue :: P.Parsec String ParseState Expr+parseValue :: TokenParser Expr parseValue = withSourceSpan PositionedValue   (P.buildExpressionParser operators     . C.buildPostfixParser postfixTable2@@ -386,68 +392,68 @@   where   indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom   postfixTable1 = [ parseAccessor-                  , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]+                  , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]   postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v-                  , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v+                  , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v                   ]-  operators = [ [ P.Prefix (C.lexeme (P.try (C.indented *> P.char '-') >> return UnaryMinus))+  operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)                 ]-              , [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->-                    return (BinaryNoParens ident))) P.AssocRight+              , [ P.Infix (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->+                    return (BinaryNoParens ident)) P.AssocRight                 ]               ] -parseStringBinder :: P.Parsec String ParseState Binder-parseStringBinder = StringBinder <$> C.stringLiteral+parseStringBinder :: TokenParser Binder+parseStringBinder = StringBinder <$> stringLiteral -parseBooleanBinder :: P.Parsec String ParseState Binder+parseBooleanBinder :: TokenParser Binder parseBooleanBinder = BooleanBinder <$> booleanLiteral -parseNumberBinder :: P.Parsec String ParseState Binder-parseNumberBinder = NumberBinder <$> (C.lexeme sign <*> C.integerOrFloat)+parseNumberBinder :: TokenParser Binder+parseNumberBinder = NumberBinder <$> (sign <*> number)   where-  sign :: P.Parsec String ParseState (Either Integer Double -> Either Integer Double)-  sign = (P.char '-' >> return (negate +++ negate))-         <|> (P.char '+' >> return id)+  sign :: TokenParser (Either Integer Double -> Either Integer Double)+  sign = (symbol' "-" >> return (negate +++ negate))+         <|> (symbol' "+" >> return id)          <|> return id -parseVarBinder :: P.Parsec String ParseState Binder+parseVarBinder :: TokenParser Binder parseVarBinder = VarBinder <$> C.parseIdent -parseNullaryConstructorBinder :: P.Parsec String ParseState Binder-parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []+parseNullaryConstructorBinder :: TokenParser Binder+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure [] -parseConstructorBinder :: P.Parsec String ParseState Binder-parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)+parseConstructorBinder :: TokenParser Binder+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens) -parseObjectBinder :: P.Parsec String ParseState Binder-parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))+parseObjectBinder :: TokenParser Binder+parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder)) -parseArrayBinder :: P.Parsec String ParseState Binder-parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)+parseArrayBinder :: TokenParser Binder+parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder) -parseNamedBinder :: P.Parsec String ParseState Binder-parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))+parseNamedBinder :: TokenParser Binder+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)                                <*> (C.indented *> parseBinder) -parseNullBinder :: P.Parsec String ParseState Binder-parseNullBinder = C.lexeme (P.char '_' *> P.notFollowedBy C.identLetter) *> return NullBinder+parseNullBinder :: TokenParser Binder+parseNullBinder = reserved "_" *> return NullBinder -parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)+parseIdentifierAndBinder :: TokenParser (String, Binder) parseIdentifierAndBinder = do-  name <- C.lexeme (C.identifierName <|> C.stringLiteral)-  _ <- C.lexeme $ C.indented *> P.char '='+  name <- lname <|> stringLiteral+  C.indented *> (equals <|> colon)   binder <- C.indented *> parseBinder   return (name, binder)  -- | -- Parse a binder ---parseBinder :: P.Parsec String ParseState Binder+parseBinder :: TokenParser Binder parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")   where-  operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]-  parseBinderAtom :: P.Parsec String ParseState Binder+  operators = [ [ P.Infix (P.try $ C.indented *> colon *> return ConsBinder) P.AssocRight ] ]+  parseBinderAtom :: TokenParser Binder   parseBinderAtom = P.choice (map P.try                     [ parseNullBinder                     , parseStringBinder@@ -458,12 +464,12 @@                     , parseConstructorBinder                     , parseObjectBinder                     , parseArrayBinder-                    , C.parens parseBinder ]) P.<?> "binder"+                    , parens parseBinder ]) P.<?> "binder"  -- | -- Parse a binder as it would appear in a top level declaration ---parseBinderNoParens :: P.Parsec String ParseState Binder+parseBinderNoParens :: TokenParser Binder parseBinderNoParens = P.choice (map P.try                   [ parseNullBinder                   , parseStringBinder@@ -474,11 +480,11 @@                   , parseNullaryConstructorBinder                   , parseObjectBinder                   , parseArrayBinder-                  , C.parens parseBinder ]) P.<?> "binder"+                  , parens parseBinder ]) P.<?> "binder" -- | -- Parse a guard ---parseGuard :: P.Parsec String ParseState Guard-parseGuard = C.pipe *> C.indented *> parseValue+parseGuard :: TokenParser Guard+parseGuard = pipe *> C.indented *> parseValue  

@@ -18,19 +18,19 @@ ) where  import Language.PureScript.Kinds-import Language.PureScript.Parser.State import Language.PureScript.Parser.Common+import Language.PureScript.Parser.Lexer import Control.Applicative import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -parseStar :: P.Parsec String ParseState Kind-parseStar = const Star <$> lexeme (P.char '*')+parseStar :: TokenParser Kind+parseStar = const Star <$> symbol' "*" -parseBang :: P.Parsec String ParseState Kind-parseBang = const Bang <$> lexeme (P.char '!')+parseBang :: TokenParser Kind+parseBang = const Bang <$> symbol' "!" -parseTypeAtom :: P.Parsec String ParseState Kind+parseTypeAtom :: TokenParser Kind parseTypeAtom = indented *> P.choice (map P.try             [ parseStar             , parseBang@@ -38,8 +38,8 @@ -- | -- Parse a kind ---parseKind :: P.Parsec String ParseState Kind+parseKind :: TokenParser Kind parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"   where-  operators = [ [ P.Prefix (lexeme (P.char '#') >> return Row) ]-              , [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]+  operators = [ [ P.Prefix (symbol' "#" >> return Row) ]+              , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ]

@@ -0,0 +1,491 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Parser.Lexer+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- The first step in the parsing process - turns source code into a list of lexemes+--+-----------------------------------------------------------------------------++{-# LANGUAGE TupleSections #-}++module Language.PureScript.Parser.Lexer +  ( PositionedToken(..)+  , Token()+  , TokenParser()+  , lex+  , anyToken+  , token+  , match+  , lparen+  , rparen+  , parens+  , lbrace+  , rbrace+  , braces+  , lsquare+  , rsquare+  , squares+  , indent+  , indentAt+  , larrow +  , rarrow +  , lfatArrow+  , rfatArrow+  , colon+  , doubleColon+  , equals+  , pipe+  , tick+  , dot+  , comma+  , semi+  , at+  , semiSep+  , semiSep1+  , commaSep+  , commaSep1+  , lname+  , qualifier+  , uname+  , uname'+  , mname+  , reserved+  , symbol+  , symbol'+  , identifier+  , stringLiteral+  , number+  , natural+  , reservedPsNames+  , reservedTypeNames+  , opChars+  )+  where++import Prelude hiding (lex)++import Data.Char (isSpace)++import Control.Monad (void, guard)+import Data.Functor.Identity++import Control.Applicative++import Language.PureScript.Parser.State+import Language.PureScript.Comments++import qualified Text.Parsec as P+import qualified Text.Parsec.Token as PT+  +data Token+  = LParen+  | RParen+  | LBrace+  | RBrace+  | LSquare+  | RSquare+  | Indent Int+  | LArrow+  | RArrow+  | LFatArrow+  | RFatArrow+  | Colon+  | DoubleColon+  | Equals+  | Pipe+  | Tick+  | Dot+  | Comma+  | Semi+  | At+  | LName String+  | UName String+  | Qualifier String+  | Symbol String+  | StringLiteral String+  | Number (Either Integer Double)+  deriving (Show, Eq, Ord)+  +prettyPrintToken :: Token -> String+prettyPrintToken LParen            = "("+prettyPrintToken RParen            = ")"+prettyPrintToken LBrace            = "{"+prettyPrintToken RBrace            = "}"+prettyPrintToken LSquare           = "["+prettyPrintToken RSquare           = "]"+prettyPrintToken LArrow            = "<-"+prettyPrintToken RArrow            = "->"+prettyPrintToken LFatArrow         = "<="+prettyPrintToken RFatArrow         = "=>"+prettyPrintToken Colon             = ":"+prettyPrintToken DoubleColon       = "::"+prettyPrintToken Equals            = "="+prettyPrintToken Pipe              = "|"+prettyPrintToken Tick              = "`"+prettyPrintToken Dot               = "."+prettyPrintToken Comma             = ","+prettyPrintToken Semi              = ";"+prettyPrintToken At                = "@"+prettyPrintToken (Indent n)        = "indentation at level " ++ show n+prettyPrintToken (LName s)         = show s+prettyPrintToken (UName s)         = show s+prettyPrintToken (Qualifier _)     = "qualifier"+prettyPrintToken (Symbol s)        = s+prettyPrintToken (StringLiteral s) = show s+prettyPrintToken (Number n)        = either show show n++data PositionedToken = PositionedToken+  { ptSourcePos :: P.SourcePos+  , ptToken     :: Token+  , ptComments  :: [Comment]+  } deriving (Eq)+  +instance Show PositionedToken where+  show = show . ptToken++lex :: FilePath -> String -> Either P.ParseError [PositionedToken]+lex filePath input = P.parse parseTokens filePath input+      +parseTokens :: P.Parsec String u [PositionedToken]+parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof++whitespace :: P.Parsec String u ()+whitespace = P.skipMany (P.satisfy isSpace)+    +parseComment :: P.Parsec String u Comment+parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace+  where+  blockComment :: P.Parsec String u String+  blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))++  lineComment :: P.Parsec String u String+  lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))++parsePositionedToken :: P.Parsec String u PositionedToken+parsePositionedToken = P.try $ do+  comments <- P.many parseComment+  pos <- P.getPosition+  tok <- parseToken+  return $ PositionedToken pos tok comments++parseToken :: P.Parsec String u Token+parseToken = P.choice+  [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow    +  , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow+  , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow    +  , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow +  , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon +  , P.try $ P.char '('    *> pure LParen+  , P.try $ P.char ')'    *> pure RParen+  , P.try $ P.char '{'    *> pure LBrace+  , P.try $ P.char '}'    *> pure RBrace+  , P.try $ P.char '['    *> pure LSquare+  , P.try $ P.char ']'    *> pure RSquare+  , P.try $ P.char '`'    *> pure Tick+  , P.try $ P.char ','    *> pure Comma+  , P.try $ P.char '='    *> P.notFollowedBy symbolChar *> pure Equals+  , P.try $ P.char ':'    *> P.notFollowedBy symbolChar *> pure Colon+  , P.try $ P.char '|'    *> P.notFollowedBy symbolChar *> pure Pipe+  , P.try $ P.char '.'    *> P.notFollowedBy symbolChar *> pure Dot+  , P.try $ P.char ';'    *> P.notFollowedBy symbolChar *> pure Semi+  , P.try $ P.char '@'    *> P.notFollowedBy symbolChar *> pure At+  , LName         <$> parseLName +  , do uName <- parseUName+       (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)+  , Symbol        <$> parseSymbol +  , StringLiteral <$> parseStringLiteral+  , Number        <$> parseNumber+  ] <* whitespace++  where+  parseLName :: P.Parsec String u String+  parseLName = (:) <$> identStart <*> P.many identLetter+  +  parseUName :: P.Parsec String u String+  parseUName = (:) <$> P.upper <*> P.many uidentLetter+  +  parseSymbol :: P.Parsec String u String+  parseSymbol = P.many1 symbolChar+  +  identStart :: P.Parsec String u Char+  identStart = P.lower <|> P.oneOf "_"+  +  identLetter :: P.Parsec String u Char+  identLetter = P.alphaNum <|> P.oneOf "_'"++  uidentLetter :: P.Parsec String u Char+  uidentLetter = P.alphaNum <|> P.char '_'++  symbolChar :: P.Parsec String u Char+  symbolChar = P.oneOf opChars+  +  parseStringLiteral :: P.Parsec String u String+  parseStringLiteral = blockString <|> PT.stringLiteral tokenParser+    where +    delimeter   = P.try (P.string "\"\"\"")+    blockString = delimeter >> P.manyTill P.anyChar delimeter+  +  parseNumber :: P.Parsec String u (Either Integer Double)+  parseNumber = (Right <$> P.try (PT.float tokenParser) <|>+                 Left <$> P.try (PT.natural tokenParser)) P.<?> "number"++-- |+-- We use Text.Parsec.Token to implement the string and number lexemes+--+langDef :: PT.GenLanguageDef String u Identity+langDef = PT.LanguageDef+  { PT.reservedNames   = []+  , PT.reservedOpNames = []+  , PT.commentStart    = ""+  , PT.commentEnd      = ""+  , PT.commentLine     = ""+  , PT.nestedComments  = True+  , PT.identStart      = fail "Identifiers not supported"+  , PT.identLetter     = fail "Identifiers not supported"+  , PT.opStart         = fail "Operators not supported"+  , PT.opLetter        = fail "Operators not supported"+  , PT.caseSensitive   = True+  }++-- |+-- A token parser based on the language definition+--+tokenParser :: PT.GenTokenParser String u Identity+tokenParser = PT.makeTokenParser langDef++type TokenParser a = P.Parsec [PositionedToken] ParseState a+ +anyToken :: TokenParser PositionedToken+anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just+ +token :: (Token -> Maybe a) -> TokenParser a+token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)++match :: Token -> TokenParser ()+match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> prettyPrintToken tok++lparen :: TokenParser ()+lparen = match LParen++rparen :: TokenParser ()+rparen = match RParen++parens :: TokenParser a -> TokenParser a+parens = P.between lparen rparen++lbrace :: TokenParser ()+lbrace = match LBrace++rbrace :: TokenParser ()+rbrace = match RBrace++braces :: TokenParser a -> TokenParser a+braces = P.between lbrace rbrace++lsquare :: TokenParser ()+lsquare = match LSquare++rsquare :: TokenParser ()+rsquare = match RSquare++squares :: TokenParser a -> TokenParser a+squares = P.between lsquare rsquare++indent :: TokenParser Int+indent = token go P.<?> "indentation"+  where+  go (Indent n) = Just n+  go _ = Nothing++indentAt :: P.Column -> TokenParser ()+indentAt n = token go P.<?> "indentation at level " ++ show n+  where+  go (Indent n') | n == n' = Just ()+  go _ = Nothing++larrow :: TokenParser ()+larrow = match LArrow++rarrow :: TokenParser ()+rarrow = match RArrow++lfatArrow :: TokenParser ()+lfatArrow = match LFatArrow++rfatArrow :: TokenParser ()+rfatArrow = match RFatArrow++colon :: TokenParser ()+colon = match Colon++doubleColon :: TokenParser ()+doubleColon = match DoubleColon++equals :: TokenParser ()+equals = match Equals++pipe :: TokenParser ()+pipe = match Pipe++tick :: TokenParser ()+tick = match Tick++dot :: TokenParser ()+dot = match Dot++comma :: TokenParser ()+comma = match Comma++semi :: TokenParser ()+semi = match Semi++at :: TokenParser ()+at = match At ++-- |+-- Parse zero or more values separated by semicolons+--+semiSep :: TokenParser a -> TokenParser [a]+semiSep = flip P.sepBy semi++-- |+-- Parse one or more values separated by semicolons+--+semiSep1 :: TokenParser a -> TokenParser [a]+semiSep1 = flip P.sepBy1 semi++-- |+-- Parse zero or more values separated by commas+--+commaSep :: TokenParser a -> TokenParser [a]+commaSep = flip P.sepBy comma++-- |+-- Parse one or more values separated by commas+--+commaSep1 :: TokenParser a -> TokenParser [a]+commaSep1 = flip P.sepBy1 comma++lname :: TokenParser String+lname = token go P.<?> "identifier"+  where+  go (LName s) = Just s+  go _ = Nothing++qualifier :: TokenParser String+qualifier = token go P.<?> "qualifier"+  where+  go (Qualifier s) = Just s+  go _ = Nothing++reserved :: String -> TokenParser ()+reserved s = token go P.<?> show s+  where+  go (LName s') | s == s' = Just ()+  go _ = Nothing++uname :: TokenParser String+uname = token go P.<?> "proper name"+  where+  go (UName s) = Just s+  go _ = Nothing++mname :: TokenParser String+mname = token go P.<?> "module name"+  where+  go (UName s) | validModuleName s = Just s+  go _ = Nothing++uname' :: String -> TokenParser ()+uname' s = token go P.<?> show s+  where+  go (UName s') | s == s' = Just ()+  go _ = Nothing+  +symbol :: TokenParser String+symbol = token go P.<?> "symbol"+  where+  go (Symbol s) = Just s+  go Colon      = Just ":"+  go LFatArrow  = Just "<="+  go _ = Nothing++symbol' :: String -> TokenParser ()+symbol' s = token go P.<?> show s+  where+  go (Symbol s') | s == s'   = Just ()+  go Colon       | s == ":"  = Just ()+  go LFatArrow   | s == "<=" = Just ()+  go _ = Nothing+  +stringLiteral :: TokenParser String+stringLiteral = token go P.<?> "string literal"+  where+  go (StringLiteral s) = Just s+  go _ = Nothing++number :: TokenParser (Either Integer Double)+number = token go P.<?> "number"+  where+  go (Number n) = Just n+  go _ = Nothing++natural :: TokenParser Integer+natural = token go P.<?> "natural"+  where+  go (Number (Left n)) = Just n+  go _ = Nothing++identifier :: TokenParser String+identifier = token go P.<?> "identifier"+  where+  go (LName s) | s `notElem` reservedPsNames = Just s+  go _ = Nothing+  +validModuleName :: String -> Bool+validModuleName s = not ('_' `elem` s)+  +-- |+-- A list of purescript reserved identifiers+--+reservedPsNames :: [String]+reservedPsNames = [ "data"+                  , "newtype"+                  , "type"+                  , "foreign"+                  , "import"+                  , "infixl"+                  , "infixr"+                  , "infix"+                  , "class"+                  , "instance"+                  , "module"+                  , "case"+                  , "of"+                  , "if"+                  , "then"+                  , "else"+                  , "do"+                  , "let"+                  , "true"+                  , "false"+                  , "in"+                  , "where"+                  ]+                  +reservedTypeNames :: [String]+reservedTypeNames = [ "forall", "where" ]++-- |+-- The characters allowed for use in operators+--+opChars :: [Char]+opChars = ":!#$%&*+./<=>?@\\^|-~"+  

@@ -24,46 +24,46 @@ import Control.Monad (when, unless)  import Language.PureScript.Types-import Language.PureScript.Parser.State import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds+import Language.PureScript.Parser.Lexer import Language.PureScript.Environment  import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -parseArray :: P.Parsec String ParseState Type+parseArray :: TokenParser Type parseArray = squares $ return tyArray -parseArrayOf :: P.Parsec String ParseState Type+parseArrayOf :: TokenParser Type parseArrayOf = squares $ TypeApp tyArray <$> parseType -parseFunction :: P.Parsec String ParseState Type-parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction+parseFunction :: TokenParser Type+parseFunction = parens $ rarrow >> return tyFunction -parseObject :: P.Parsec String ParseState Type+parseObject :: TokenParser Type parseObject = braces $ TypeApp tyObject <$> parseRow -parseTypeWildcard :: P.Parsec String ParseState Type-parseTypeWildcard = lexeme (P.char '_') >> return TypeWildcard+parseTypeWildcard :: TokenParser Type+parseTypeWildcard = reserved "_" >> return TypeWildcard -parseTypeVariable :: P.Parsec String ParseState Type+parseTypeVariable :: TokenParser Type parseTypeVariable = do   ident <- identifier   when (ident `elem` reservedTypeNames) $ P.unexpected ident   return $ TypeVar ident -parseTypeConstructor :: P.Parsec String ParseState Type+parseTypeConstructor :: TokenParser Type parseTypeConstructor = TypeConstructor <$> parseQualified properName -parseForAll :: P.Parsec String ParseState Type+parseForAll :: TokenParser Type parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)                        <*> parseConstrainedType  -- | -- Parse a type as it appears in e.g. a data constructor ---parseTypeAtom :: P.Parsec String ParseState Type+parseTypeAtom :: TokenParser Type parseTypeAtom = indented *> P.choice (map P.try             [ parseArray             , parseArrayOf@@ -76,7 +76,7 @@             , parens parseRow             , parens parsePolyType ]) -parseConstrainedType :: P.Parsec String ParseState Type+parseConstrainedType :: TokenParser Type parseConstrainedType = do   constraints <- P.optionMaybe . P.try $ do     constraints <- parens . commaSep1 $ do@@ -84,24 +84,24 @@       indented       ty <- P.many parseTypeAtom       return (className, ty)-    _ <- lexeme $ P.string "=>"+    _ <- rfatArrow     return constraints   indented   ty <- parseType   return $ maybe ty (flip ConstrainedType ty) constraints -parseAnyType :: P.Parsec String ParseState Type+parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"   where   operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]-              , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]-  postfixTable = [ \t -> KindedType t <$> (P.try (lexeme (indented *> P.string "::")) *> parseKind)+              , [ P.Infix (rarrow >> return function) P.AssocRight ] ]+  postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)                  ]  -- | -- Parse a monotype ---parseType :: P.Parsec String ParseState Type+parseType :: TokenParser Type parseType = do   ty <- parseAnyType   unless (isMonoType ty) $ P.unexpected "polymorphic type"@@ -110,23 +110,25 @@ -- | -- Parse a polytype ---parsePolyType :: P.Parsec String ParseState Type+parsePolyType :: TokenParser Type parsePolyType = parseAnyType  -- | -- Parse an atomic type with no wildcards ---noWildcards :: P.Parsec String ParseState Type -> P.Parsec String ParseState Type+noWildcards :: TokenParser Type -> TokenParser Type noWildcards p = do   ty <- p   when (containsWildcards ty) $ P.unexpected "type wildcard"   return ty -parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)-parseNameAndType p = (,) <$> (indented *> (identifierName <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p+parseNameAndType :: TokenParser t -> TokenParser (String, t)+parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p -parseRowEnding :: P.Parsec String ParseState Type-parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))+parseRowEnding :: TokenParser Type+parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice  (map P.try+            [ parseTypeWildcard+            , TypeVar <$> identifier ]) -parseRow :: P.Parsec String ParseState Type+parseRow :: TokenParser Type parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

@@ -17,7 +17,7 @@  import Control.Monad.State import Data.List (intercalate)-import Language.PureScript.Parser.Common (reservedPsNames, opChars)+import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)  -- | -- Wrap a string in parentheses

@@ -17,17 +17,20 @@     prettyPrintJS ) where -import Language.PureScript.Pretty.Common-import Language.PureScript.CodeGen.JS (identNeedsEscaping)-import Language.PureScript.CodeGen.JS.AST- import Data.List import Data.Maybe (fromMaybe)-import qualified Control.Arrow as A-import Control.Arrow ((<+>))-import Control.PatternArrows+ import Control.Applicative+import Control.Arrow ((<+>)) import Control.Monad.State+import Control.PatternArrows+import qualified Control.Arrow as A++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.CodeGen.JS.Common+import Language.PureScript.Pretty.Common+import Language.PureScript.Comments+ import Numeric  literals :: Pattern PrinterState JS String@@ -117,6 +120,32 @@     [ return $ lbl ++ ": "     , prettyPrintJS' js     ]+  match (JSComment com js) = fmap concat $ sequence $+    [ return "\n"+    , currentIndent+    , return "/**\n"+    ] +++    map asLine (concatMap commentLines com) +++    [ currentIndent+    , return " */\n"+    , currentIndent+    , prettyPrintJS' js+    ]+    where+    commentLines :: Comment -> [String]+    commentLines (LineComment s) = [s]+    commentLines (BlockComment s) = lines s+    +    asLine :: String -> StateT PrinterState Maybe String +    asLine s = do+      i <- currentIndent+      return $ i ++ " * " ++ removeComments s ++ "\n"+    +    removeComments :: String -> String+    removeComments ('*' : '/' : s) = removeComments s+    removeComments (c : s) = c : removeComments s+    +    removeComments [] = []   match (JSRaw js) = return js   match _ = mzero 

@@ -81,7 +81,7 @@   match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"   match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"   match (TypedValue _ val _) = prettyPrintValue' val-  match (PositionedValue _ val) = prettyPrintValue' val+  match (PositionedValue _ _ val) = prettyPrintValue' val   match _ = mzero  prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String@@ -90,7 +90,7 @@   [ return $ show ident ++ " = "   , prettyPrintValue' val   ]-prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d+prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"  prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String@@ -126,7 +126,7 @@     [ return "let "     , withIndent $ prettyPrintMany prettyPrintDeclaration ds     ]-prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el+prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el  ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr) ifThenElse = mkPattern match@@ -204,7 +204,7 @@     , return "]"     ]   match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder-  match (PositionedBinder _ binder) = prettyPrintBinder' binder+  match (PositionedBinder _ _ binder) = prettyPrintBinder' binder   match _ = mzero  -- |

@@ -1,4 +1,5 @@ -----------------------------------------------------------------------------+----------------------------------------------------------------------------- -- -- Module      :  Language.PureScript.Renamer -- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors@@ -23,8 +24,7 @@ import qualified Data.Map as M import qualified Data.Set as S -import Language.PureScript.AST-import Language.PureScript.Environment+import Language.PureScript.CoreFn import Language.PureScript.Names import Language.PureScript.Traversals @@ -100,25 +100,21 @@ -- | -- Finds idents introduced by declarations. ---findDeclIdents :: [Declaration] -> [Ident]+findDeclIdents :: [Bind Ann] -> [Ident] findDeclIdents = concatMap go   where-  go (ValueDeclaration ident _ _ _) = [ident]-  go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds-  go (ExternDeclaration _ ident _ _) = [ident]-  go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds-  go (PositionedDeclaration _ d) = go d-  go _ = []+  go (NonRec ident _) = [ident]+  go (Rec ds) = map fst ds  -- | -- Renames within each declaration in a module. ---renameInModules :: [Module] -> [Module]+renameInModules :: [Module Ann] -> [Module Ann] renameInModules = map go   where-  go :: Module -> Module-  go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps-  renameInDecl' :: [Ident] -> Declaration -> Declaration+  go :: Module Ann -> Module Ann+  go m@(Module _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }+  renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann   renameInDecl' scope = runRename scope . renameInDecl True  -- |@@ -128,65 +124,57 @@ -- been added), whereas in a Let declarations are renamed if their name shadows -- another in the current scope. ---renameInDecl :: Bool -> Declaration -> Rename Declaration-renameInDecl isTopLevel (ValueDeclaration name nameKind [] (Right val)) = do+renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)+renameInDecl isTopLevel (NonRec name val) = do   name' <- if isTopLevel then return name else updateScope name-  ValueDeclaration name' nameKind [] . Right <$> renameInValue val-renameInDecl isTopLevel (BindingGroupDeclaration ds) = do+  NonRec name' <$> renameInValue val+renameInDecl isTopLevel (Rec ds) = do   ds' <- mapM updateNames ds-  BindingGroupDeclaration <$> mapM updateValues ds'+  Rec <$> mapM updateValues ds'   where-  updateNames :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)-  updateNames (name, nameKind, val) = do+  updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)+  updateNames (name, val) = do     name' <- if isTopLevel then return name else updateScope name-    return (name', nameKind, val)-  updateValues :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)-  updateValues (name, nameKind, val) =-    (,,) name nameKind <$> renameInValue val-renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =-  TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds-renameInDecl isTopLevel (PositionedDeclaration pos d) =-  PositionedDeclaration pos <$> renameInDecl isTopLevel d-renameInDecl _ other = return other+    return (name', val)+  updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)+  updateValues (name, val) = (,) name <$> renameInValue val  -- | -- Renames within a value. ---renameInValue :: Expr -> Rename Expr-renameInValue (UnaryMinus v) =-  UnaryMinus <$> renameInValue v-renameInValue (ArrayLiteral vs) =-  ArrayLiteral <$> mapM renameInValue vs-renameInValue (ObjectLiteral vs) =-  ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs-renameInValue (Accessor prop v) =-  Accessor prop <$> renameInValue v-renameInValue (ObjectUpdate obj vs) =-  ObjectUpdate <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs-renameInValue (Abs (Left name) v) =-  newScope $ Abs . Left <$> updateScope name <*> renameInValue v-renameInValue (App v1 v2) =-  App <$> renameInValue v1 <*> renameInValue v2-renameInValue (Var (Qualified Nothing name)) =-  Var . Qualified Nothing <$> lookupIdent name-renameInValue (IfThenElse v1 v2 v3) =-  IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3-renameInValue (Case vs alts) =-  newScope $ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts-renameInValue (TypedValue check v ty) =-  TypedValue check <$> renameInValue v <*> pure ty-renameInValue (Let ds v) =-  newScope $ Let <$> mapM (renameInDecl False) ds <*> renameInValue v-renameInValue (TypeClassDictionaryConstructorApp name v) =-  TypeClassDictionaryConstructorApp name <$> renameInValue v-renameInValue (PositionedValue pos v) =-  PositionedValue pos <$> renameInValue v-renameInValue v = return v+renameInValue :: Expr Ann -> Rename (Expr Ann)+renameInValue (Literal ann l) =+  Literal ann <$> renameInLiteral renameInValue l+renameInValue c@(Constructor{}) = return c+renameInValue (Accessor ann prop v) =+  Accessor ann prop <$> renameInValue v+renameInValue (ObjectUpdate ann obj vs) =+  ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs+renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e+renameInValue (Abs ann name v) =+  newScope $ Abs ann <$> updateScope name <*> renameInValue v+renameInValue (App ann v1 v2) =+  App ann <$> renameInValue v1 <*> renameInValue v2+renameInValue (Var ann (Qualified Nothing name)) =+  Var ann . Qualified Nothing <$> lookupIdent name+renameInValue v@(Var{}) = return v+renameInValue (Case ann vs alts) =+  newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts+renameInValue (Let ann ds v) =+  newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v  -- |+-- Renames within literals.+--+renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)+renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs+renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs+renameInLiteral _ l = return l++-- | -- Renames within case alternatives. ---renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative+renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann) renameInCaseAlternative (CaseAlternative bs v) =   CaseAlternative <$> mapM renameInBinder bs                   <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v@@ -194,18 +182,13 @@ -- | -- Renames within binders. ---renameInBinder :: Binder -> Rename Binder-renameInBinder (VarBinder name) =-  VarBinder <$> updateScope name-renameInBinder (ConstructorBinder name bs) =-  ConstructorBinder name <$> mapM renameInBinder bs-renameInBinder (ObjectBinder bs) =-  ObjectBinder <$> mapM (sndM renameInBinder) bs-renameInBinder (ArrayBinder bs) =-  ArrayBinder <$> mapM renameInBinder bs-renameInBinder (ConsBinder b1 b2) =-  ConsBinder <$> renameInBinder b1 <*> renameInBinder b2-renameInBinder (NamedBinder name b) =-  NamedBinder <$> updateScope name <*> renameInBinder b-renameInBinder (PositionedBinder _ b) = renameInBinder b-renameInBinder other = return other+renameInBinder :: Binder a -> Rename (Binder a)+renameInBinder n@(NullBinder{}) = return n+renameInBinder (LiteralBinder ann b) =+  LiteralBinder ann <$> renameInLiteral renameInBinder b+renameInBinder (VarBinder ann name) =+  VarBinder ann <$> updateScope name+renameInBinder (ConstructorBinder ann tctor dctor bs) =+  ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs+renameInBinder (NamedBinder ann name b) =+  NamedBinder ann <$> updateScope name <*> renameInBinder b

@@ -88,7 +88,7 @@   where   go (DataBindingGroupDeclaration ds) = ds   go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds-  go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d+  go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d   go other = [other]  collapseBindingGroupsForValue :: Expr -> Expr@@ -139,13 +139,13 @@  getIdent :: Declaration -> Ident getIdent (ValueDeclaration ident _ _ _) = ident-getIdent (PositionedDeclaration _ d) = getIdent d+getIdent (PositionedDeclaration _ _ d) = getIdent d getIdent _ = error "Expected ValueDeclaration"  getProperName :: Declaration -> ProperName getProperName (DataDeclaration _ pn _ _) = pn getProperName (TypeSynonymDeclaration pn _ _) = pn-getProperName (PositionedDeclaration _ d) = getProperName d+getProperName (PositionedDeclaration _ _ d) = getProperName d getProperName _ = error "Expected DataDeclaration"  -- |@@ -178,7 +178,7 @@   toBinding (CyclicSCC ~(d:ds)) = cycleError d ds    cycleError :: Declaration -> [Declaration] -> Either ErrorStack a-  cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds+  cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds   cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $     mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))   cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []@@ -195,11 +195,11 @@  isTypeSynonym :: Declaration -> Maybe ProperName isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn-isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d+isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d isTypeSynonym _ = Nothing  fromValueDecl :: Declaration -> (Ident, NameKind, Expr) fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val) fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"-fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d+fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d fromValueDecl _ = error "Expected ValueDeclaration"

@@ -75,16 +75,16 @@       where       go (Let ds val') = Let <$> desugarCases ds <*> pure val'       go other = return other-    desugarRest (PositionedDeclaration pos d : ds) = do+    desugarRest (PositionedDeclaration pos com d : ds) = do       (d' : ds') <- desugarRest (d : ds)-      return (PositionedDeclaration pos d' : ds')+      return (PositionedDeclaration pos com d' : ds')     desugarRest (d : ds) = (:) d <$> desugarRest ds     desugarRest [] = pure []  inSameGroup :: Declaration -> Declaration -> Bool inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2-inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2-inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2+inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2+inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False  toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]@@ -101,9 +101,9 @@       throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing   caseDecl <- makeCaseDeclaration ident tuples   return [caseDecl]-toDecls (PositionedDeclaration pos d : ds) = do+toDecls (PositionedDeclaration pos com d : ds) = do   (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)-  return (PositionedDeclaration pos d' : ds')+  return (PositionedDeclaration pos com d' : ds') toDecls ds = return ds  isVarBinder :: Binder -> Bool@@ -112,7 +112,7 @@  toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr) toTuple (ValueDeclaration _ _ bs result) = (bs, result)-toTuple (PositionedDeclaration _ d) = toTuple d+toTuple (PositionedDeclaration _ _ d) = toTuple d toTuple _ = error "Not a value declaration"  makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration

@@ -36,7 +36,7 @@ desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts  desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration-desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)+desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d) desugarDo d =   let (f, _, _) = everywhereOnValuesM return replace return   in f d@@ -49,7 +49,7 @@    replace :: Expr -> SupplyT (Either ErrorStack) Expr   replace (Do els) = go els-  replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)+  replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)   replace other = return other    go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr@@ -71,4 +71,4 @@   go (DoNotationLet ds : rest) = do     rest' <- go rest     return $ Let ds rest'-  go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)+  go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)

@@ -199,7 +199,7 @@   (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS    updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)-  updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)+  updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)   updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =     (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)   updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =@@ -217,7 +217,7 @@   updateDecl s d = return (s, d)    updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)-  updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)+  updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)   updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')   updateValue (pos, bound) (Let ds val') =       let args = mapMaybe letBoundVariable ds@@ -235,7 +235,7 @@   updateValue s v = return (s, v)    updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)-  updateBinder (_, bound) v@(PositionedBinder pos _) = return ((Just pos, bound), v)+  updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)   updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)   updateBinder s v = return (s, v) @@ -244,7 +244,7 @@    letBoundVariable :: Declaration -> Maybe Ident   letBoundVariable (ValueDeclaration ident _ _ _) = Just ident-  letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d+  letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d   letBoundVariable _ = Nothing    updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type@@ -317,14 +317,14 @@     foldM go env' ds     where     go env'' (TypeDeclaration name _) = addValue env'' mn name-    go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d+    go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d     go _ _ = error "Invalid declaration in TypeClassDeclaration"   addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)   addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []   addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []   addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name   addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name-  addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d+  addDecl mn env (PositionedDeclaration _ _ d) = addDecl mn env d   addDecl _  env _ = return env  -- |@@ -349,7 +349,7 @@   -- Ensure the exported types and data constructors exist in the module and add them to the set of   -- exports   filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]-  filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r+  filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r   filterTypes expTys result (TypeRef name expDcons) = do     dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys     dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons@@ -365,7 +365,7 @@    -- Ensure the exported classes exist in the module and add them to the set of exports   filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]-  filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r+  filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r   filterClasses exps' result (TypeClassRef name) =     if name `elem` exps'     then return $ name : result@@ -374,7 +374,7 @@    -- Ensure the exported values exist in the module and add them to the set of exports   filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]-  filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r+  filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r   filterValues exps' result (ValueRef name) =     if name `elem` exps'     then return $ name : result@@ -389,7 +389,7 @@ findImports = foldl (findImports' Nothing) M.empty   where   findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result-  findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d+  findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d   findImports' _ result _ = result  -- |@@ -443,7 +443,7 @@       checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc       checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'       checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'-      checkTypeRef (PositionedDeclarationRef _ r) acc hiddenRef = checkTypeRef r acc hiddenRef+      checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef       checkTypeRef _ acc _ = acc     in foldl (checkTypeRef ref) False hidden   isHidden hidden ref = ref `elem` hidden@@ -457,7 +457,7 @@    -- Import something explicitly   importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment-  importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r+  importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r   importExplicit imp (ValueRef name) = do     values' <- updateImports (importedValues imp) name     return $ imp { importedValues = values' }@@ -476,7 +476,7 @@   checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]   checkedRefs = mapM check     where-    check (PositionedDeclarationRef pos r) =+    check (PositionedDeclarationRef pos _ r) =       rethrowWithPosition pos $ check r     check ref@(ValueRef name) =       checkImportExists "value" values name >> return ref

@@ -80,7 +80,7 @@ collectFixities (Module moduleName ds _) = concatMap collect ds   where   collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]-  collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]+  collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]   collect FixityDeclaration{} = error "Fixity without srcpos info"   collect _ = [] 

@@ -14,11 +14,13 @@ -- ----------------------------------------------------------------------------- -module Language.PureScript.Sugar.TypeClasses (-  desugarTypeClasses-) where+module Language.PureScript.Sugar.TypeClasses+  ( desugarTypeClasses+  , typeClassMemberName+  , superClassDictionaryNames+  ) where -import Language.PureScript.AST+import Language.PureScript.AST hiding (isExported) import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Kinds@@ -162,9 +164,9 @@     desugared <- lift $ desugarCases members     dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared     return $ (expRef name className tys, [d, dictDecl])-  go (PositionedDeclaration pos d) = do+  go (PositionedDeclaration pos com d) = do     (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d-    return (dr, map (PositionedDeclaration pos) ds)+    return (dr, map (PositionedDeclaration pos com) ds)   go other = return (Nothing, [other])    expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef@@ -195,16 +197,15 @@  memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)-memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d+memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d memberToNameAndType _ = error "Invalid declaration in type class definition" -typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration+typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration typeClassDictionaryDeclaration name args implies members =-  let superclassTypes = [ (fieldName, function unit tySynApp)-                        | (index, (superclass, tyArgs)) <- zip [0..] implies-                        , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs-                        , let fieldName = mkSuperclassDictionaryName superclass index-                        ]+  let superclassTypes = superClassDictionaryNames implies `zip`+        [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)+        | (superclass, tyArgs) <- implies+        ]       members' = map (first runIdent . memberToNameAndType) members       mtys = members' ++ superclassTypes   in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))@@ -214,17 +215,14 @@   ValueDeclaration ident TypeClassAccessorImport [] $ Right $     TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $     moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))-typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =-  PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d+typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =+  PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition" -mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String-mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index- unit :: Type unit = TypeApp tyObject REmpty -typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration+typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls =   rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do   m <- get@@ -242,46 +240,51 @@        -- Replace the type arguments with the appropriate types in the member types       let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys+       -- Create values for the type instance members-      memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls+      members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls+       -- Create the type of the dictionary       -- The type is an object type, but depending on type instance dependencies, may be constrained.       -- The dictionary itself is an object literal.-      let superclasses =-            [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))-            | (index, (superclass, suTyArgs)) <- zip [0..] implies+      let superclasses = superClassDictionaryNames implies `zip`+            [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)+            | (superclass, suTyArgs) <- implies             , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs-            , let fieldName = mkSuperclassDictionaryName superclass index             ] -      let memberNames' = ObjectLiteral (memberNames ++ superclasses)+      let props = ObjectLiteral (members ++ superclasses)           dictTy = foldl TypeApp (TypeConstructor className) tys           constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)-          dict = TypeClassDictionaryConstructorApp className memberNames'+          dict = TypeClassDictionaryConstructorApp className props           result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))       return result    where    declName :: Declaration -> Maybe Ident-  declName (PositionedDeclaration _ d) = declName d+  declName (PositionedDeclaration _ _ d) = declName d   declName (ValueDeclaration ident _ _ _) = Just ident   declName (TypeDeclaration ident _) = Just ident   declName _ = Nothing -  memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)-  memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _) = do+  memberToValue :: [(Ident, Type)] -> Declaration -> Desugar Expr+  memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do     _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'-    let memberValue = typeInstanceDictionaryEntryValue d-    return (ident, memberValue)-  memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do-    (ident, val) <- memberToNameAndValue tys' d-    return (ident, PositionedValue pos val)-  memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"--  typeInstanceDictionaryEntryValue :: Declaration -> Expr-  typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] (Right val)) = val-  typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)-  typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"+    return val+  memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do+    val <- memberToValue tys' d+    return (PositionedValue pos com val)+  memberToValue _ _ = error "Invalid declaration in type instance definition" +typeClassMemberName :: Declaration -> String+typeClassMemberName (TypeDeclaration ident _) = runIdent ident+typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident+typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d+typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d +superClassDictionaryNames :: [Constraint] -> [String]+superClassDictionaryNames supers =+  [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)+  | (index, (pn, _)) <- zip [0..] supers+  ]

@@ -43,18 +43,18 @@ -- Replace all top level type declarations with type annotations -- desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]-desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do+desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do   (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)-  return (PositionedDeclaration pos d' : ds')+  return (PositionedDeclaration pos com d' : ds') desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do   (_, nameKind, val) <- fromValueDeclaration d   desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)   where   fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)   fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)-  fromValueDeclaration (PositionedDeclaration pos d') = do+  fromValueDeclaration (PositionedDeclaration pos com d') = do     (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'-    return (ident, nameKind, PositionedValue pos val)+    return (ident, nameKind, PositionedValue pos com val)   fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

@@ -78,13 +78,13 @@   env <- getEnv   putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) -addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check () addTypeClass moduleName pn args implies ds =   let members = map toPair ds in   modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }   where   toPair (TypeDeclaration ident ty) = (ident, ty)-  toPair (PositionedDeclaration _ d) = toPair d+  toPair (PositionedDeclaration _ _ d) = toPair d   toPair _ = error "Invalid declaration in TypeClassDeclaration"  addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()@@ -163,10 +163,10 @@     return $ d : ds     where     toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)-    toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'+    toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'     toTypeSynonym _ = Nothing     toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)-    toDataDecl (PositionedDeclaration _ d') = toDataDecl d'+    toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'     toDataDecl _ = Nothing   go (TypeSynonymDeclaration name args ty : rest) = do     rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do@@ -235,28 +235,32 @@     addTypeClass moduleName pn args implies tys     ds <- go rest     return $ d : ds-  go (TypeInstanceDeclaration dictName deps className tys _ : rest) =-    go (ExternInstanceDeclaration dictName deps className tys : rest)+  go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do+    goInstance d dictName deps className tys rest   go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do+    goInstance d dictName deps className tys rest+  go (PositionedDeclaration pos com d : rest) =+    rethrowWithPosition pos $ do+      (d' : rest') <- go (d : rest)+      return (PositionedDeclaration pos com d' : rest')+  goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]+  goInstance d dictName deps className tys rest = do     mapM_ (checkTypeClassInstance moduleName) tys     forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd     addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]     ds <- go rest     return $ d : ds+     where+     isInstanceExported :: Bool     isInstanceExported = any exportsInstance exps      exportsInstance :: DeclarationRef -> Bool     exportsInstance (TypeInstanceRef name) | name == dictName = True-    exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r+    exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r     exportsInstance _ = False -  go (PositionedDeclaration pos d : rest) =-    rethrowWithPosition pos $ do-      (d' : rest') <- go (d : rest)-      return (PositionedDeclaration pos d' : rest')-   -- |   -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,   -- extracted from the kind of the type constructor itself.@@ -342,10 +346,10 @@     runValueRef _ = error "non-ValueRef passed to runValueRef"     findClassMembers :: Declaration -> Maybe [Ident]     findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds-    findClassMembers (PositionedDeclaration _ d) = findClassMembers d+    findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d     findClassMembers _ = Nothing     extractMemberName :: Declaration -> Ident-    extractMemberName (PositionedDeclaration _ d) = extractMemberName d+    extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d     extractMemberName (TypeDeclaration memberName _) = memberName     extractMemberName _ = error "Unexpected declaration in typeclass member list"   checkClassMembersAreExported _ = return ()

@@ -64,7 +64,7 @@ -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. ---entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))   where     sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]@@ -107,7 +107,7 @@       -- Create dictionaries for subgoals which still need to be solved by calling go recursively       -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type       -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.-      solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]+      solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> [Maybe [DictionaryValue]]       solveSubgoals _ Nothing = return Nothing       solveSubgoals subst (Just subgoals) = do         dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals

@@ -296,7 +296,7 @@   ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty   val' <- if checkType then check val ty' else return val   return $ TypedValue True val' ty'-infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val+infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val infer' _ = error "Invalid argument to infer"  inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)@@ -322,9 +322,9 @@   ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict   let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']   makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j-inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do   (d' : ds', val') <- inferLetBinding seen (d : ds) ret j-  return (PositionedDeclaration pos d' : ds', val')+  return (PositionedDeclaration pos com d' : ds', val') inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"  -- |@@ -394,7 +394,7 @@ inferBinder val (NamedBinder name binder) = do   m <- inferBinder val binder   return $ M.insert name val m-inferBinder val (PositionedBinder pos binder) =+inferBinder val (PositionedBinder pos _ binder) =   rethrowWithPosition pos $ inferBinder val binder  -- |@@ -563,7 +563,7 @@   guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star   val' <- check' val ty   return $ TypedValue True val' kt-check' (PositionedValue pos val) ty =+check' (PositionedValue pos _ val) ty =   rethrowWithPosition pos $ check val ty check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val)) 

@@ -41,7 +41,7 @@     -- |     -- Type class dependencies which must be satisfied to construct this dictionary     ---    , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]+    , tcdDependencies :: Maybe [Constraint]     -- |     -- The type of this dictionary     --

@@ -69,7 +69,7 @@   -- |   -- A type with a set of type class constraints   ---  | ConstrainedType [(Qualified ProperName, [Type])] Type+  | ConstrainedType [Constraint] Type   -- |   -- A skolem constant   --@@ -84,7 +84,7 @@   | RCons String Type Type   -- |   -- A type with a kind annotation-  -- +  --   | KindedType Type Kind   --   -- |@@ -105,6 +105,11 @@   | PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)  -- |+-- A typeclass constraint+--+type Constraint = (Qualified ProperName, [Type])++-- | -- Convert a row to a list of pairs of labels and types -- rowToList :: Type -> ([(String, Type)], Type)@@ -144,9 +149,9 @@ replaceAllTypeVars :: [(String, Type)] -> Type -> Type replaceAllTypeVars = go []   where-      +   go :: [String] -> [(String, Type)] -> Type -> Type-  go _  m (TypeVar v) = +  go _  m (TypeVar v) =     case v `lookup` m of       Just r -> r       Nothing -> TypeVar v@@ -165,7 +170,7 @@   go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)   go bs m (KindedType t k) = KindedType (go bs m t) k   go _  _ ty = ty-  +   genName orig inUse = try 0     where     try :: Integer -> String