create UnusedIdent (purescript#3194)

matthewleon · garyb · commit 8369db42eebe · 2018-01-20T22:56:01.000Z
Fixes purescript#3187 Rather than using the magic string "__unused" to represent generated names that are meant to go unused, we create a new Ident constructor for them. Instead of eliminating them as arguments in the optimization phase, they are stripped during the conversion from CoreFn to CoreImp.
diff --git a/examples/passing/3187-UnusedNameClash.purs b/examples/passing/3187-UnusedNameClash.purs
@@ -0,0 +1,12 @@
+module Main (main) where
+
+import Prelude ((+))
+import Control.Monad.Eff.Console (log)
+
+-- the __unused parameter used to get optimized away
+abuseUnused :: forall a. a -> a
+abuseUnused __unused = __unused
+
+main = do
+  let explode = abuseUnused 0 + abuseUnused 0
+  log "Done"
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
@@ -164,6 +164,7 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ =
   accessor :: Ident -> AST -> AST
   accessor (Ident prop) = accessorString $ mkString prop
   accessor (GenIdent _ _) = internalError "GenIdent in accessor"
+  accessor UnusedIdent = internalError "UnusedIdent in accessor"
 
   accessorString :: PSString -> AST -> AST
   accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
@@ -199,7 +200,10 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ =
                                (var name)
   valueToJs' (Abs _ arg val) = do
     ret <- valueToJs val
-    return $ AST.Function Nothing Nothing [identToJs arg] (AST.Block Nothing [AST.Return Nothing ret])
+    let jsArg = case arg of
+                  UnusedIdent -> []
+                  _           -> [identToJs arg]
+    return $ AST.Function Nothing Nothing jsArg (AST.Block Nothing [AST.Return Nothing ret])
   valueToJs' e@App{} = do
     let (f, args) = unApp e []
     args' <- mapM valueToJs args
diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -26,6 +26,7 @@ moduleNameToJs (ModuleName pns) =
 identToJs :: Ident -> Text
 identToJs (Ident name) = properToJs name
 identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
+identToJs UnusedIdent = "$__unused"
 
 properToJs :: Text -> Text
 properToJs name
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
@@ -418,11 +418,6 @@ typ = "Type"
 symbol :: forall a. (IsString a) => a
 symbol = "Symbol"
 
--- Code Generation
-
-__unused :: forall a. (IsString a) => a
-__unused = "__unused"
-
 -- Modules
 
 prim :: forall a. (IsString a) => a
diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs
@@ -44,7 +44,6 @@ optimize js = do
       [ collapseNestedBlocks
       , collapseNestedIfs
       , removeCodeAfterReturnStatements
-      , removeUnusedArg
       , removeUndefinedApp
       , unThunk
       , etaConvert
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs
@@ -1,7 +1,6 @@
 -- | Removes unused variables
 module Language.PureScript.CoreImp.Optimizer.Unused
   ( removeCodeAfterReturnStatements
-  , removeUnusedArg
   , removeUndefinedApp
   ) where
 
@@ -21,12 +20,6 @@ removeCodeAfterReturnStatements = everywhere (removeFromBlock go)
   isReturn (ReturnNoResult _) = True
   isReturn _ = False
 
-removeUnusedArg :: AST -> AST
-removeUnusedArg = everywhere convert
-  where
-  convert (Function ss name [arg] body) | arg == C.__unused = Function ss name [] body
-  convert js = js
-
 removeUndefinedApp :: AST -> AST
 removeUndefinedApp = everywhere convert
   where
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -291,11 +291,11 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl'
     return $
       Let
         [ partial var tyVar ]
-        $ App (Var (Qualified Nothing (Ident C.__unused))) e
+        $ App (Var (Qualified Nothing UnusedIdent)) e
     where
       partial :: Text -> Text -> Declaration
       partial var tyVar =
-        ValueDecl (ss, []) (Ident C.__unused) Private [] $
+        ValueDecl (ss, []) UnusedIdent Private [] $
         [MkUnguarded
           (TypedValue
            True
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
@@ -76,6 +76,10 @@ data Ident
   -- A generated name for an identifier
   --
   | GenIdent (Maybe Text) Integer
+  -- |
+  -- A generated name used only for type-checking
+  --
+  | UnusedIdent
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData Ident
@@ -84,6 +88,7 @@ runIdent :: Ident -> Text
 runIdent (Ident i) = i
 runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
 runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
+runIdent UnusedIdent = "$__unused"
 
 showIdent :: Ident -> Text
 showIdent = runIdent
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
@@ -17,7 +17,6 @@ import qualified Data.Text as T
 import Language.PureScript.CoreFn
 import Language.PureScript.Names
 import Language.PureScript.Traversals
-import qualified Language.PureScript.Constants as C
 
 -- |
 -- The state object used in this module
@@ -62,8 +61,8 @@ newScope x = do
 updateScope :: Ident -> Rename Ident
 updateScope ident =
   case ident of
-    Ident name | name == C.__unused -> return ident
     GenIdent name _ -> go ident $ Ident (fromMaybe "v" name)
+    UnusedIdent -> return UnusedIdent
     _ -> go ident ident
   where
   go :: Ident -> Ident -> Rename Ident
@@ -88,7 +87,7 @@ updateScope ident =
 -- Finds the new name to use for an ident.
 --
 lookupIdent :: Ident -> Rename Ident
-lookupIdent i@(Ident name) | name == C.__unused = return i
+lookupIdent UnusedIdent = return UnusedIdent
 lookupIdent name = do
   name' <- gets $ M.lookup name . rsBoundNames
   case name' of
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -44,7 +44,7 @@ desugarDo d =
   go [DoNotationValue val] = return val
   go (DoNotationValue val : rest) = do
     rest' <- go rest
-    return $ App (App discard val) (Abs (VarBinder (Ident C.__unused)) rest')
+    return $ App (App discard val) (Abs (VarBinder UnusedIdent) rest')
   go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind
   go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) =
       throwError . errorMessage $ CannotUseBindWithDo (Ident ident)
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -292,7 +292,7 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls =
       -- The type is a record type, but depending on type instance dependencies, may be constrained.
       -- The dictionary itself is a record literal.
       let superclasses = superClassDictionaryNames typeClassSuperclasses `zip`
-            [ Abs (VarBinder (Ident C.__unused)) (DeferredDictionary superclass tyArgs)
+            [ Abs (VarBinder UnusedIdent) (DeferredDictionary superclass tyArgs)
             | (Constraint superclass suTyArgs _) <- typeClassSuperclasses
             , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs
             ]
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -360,7 +360,7 @@ entails SolverOptions{..} constraint context hints =
             mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args)
             mkDictionary UnionInstance (Just [e]) =
               -- We need the subgoal dictionary to appear in the term somewhere
-              return $ App (Abs (VarBinder (Ident C.__unused)) valUndefined) e
+              return $ App (Abs (VarBinder UnusedIdent) valUndefined) e
             mkDictionary UnionInstance _ = return valUndefined
             mkDictionary ConsInstance _ = return valUndefined
             mkDictionary RowToListInstance _ = return valUndefined
@@ -371,7 +371,7 @@ entails SolverOptions{..} constraint context hints =
               -- So pass an empty placeholder (undefined) instead.
               return valUndefined
             mkDictionary (IsSymbolInstance sym) _ =
-              let fields = [ ("reflectSymbol", Abs (VarBinder (Ident C.__unused)) (Literal (StringLiteral sym))) ] in
+              let fields = [ ("reflectSymbol", Abs (VarBinder UnusedIdent) (Literal (StringLiteral sym))) ] in
               return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))
             mkDictionary CompareSymbolInstance _ =
               return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))
