Skip to content

Rewrite Partial optimization to be cleaner #4208

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
rhendric merged 1 commit into from
Jan 30, 2022
Merged

Rewrite Partial optimization to be cleaner #4208

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 5 additions & 0 deletions CHANGELOG.d/feature_rewrite-partial-optimization.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
* Rewrite `Partial` optimization to be cleaner

This feature shrinks the generated JS code for declarations that use
empty type classes, such as `Partial`, but is otherwise not expected to
have user-visible consequences.
11 changes: 1 addition & 10 deletions src/Language/PureScript/CoreFn/Optimizer.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -27,8 +27,7 @@ optimizeModuleDecls = map transformBinds
where
(transformBinds, _, _) = everywhereOnValues identity transformExprs identity
transformExprs
= optimizeUnusedPartialFn
. optimizeClosedRecordUpdate
= optimizeClosedRecordUpdate
. optimizeDataFunctionApply

optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann
Expand All @@ -52,14 +51,6 @@ closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) =
collect _ = Nothing
closedRecordFields _ = Nothing

-- | See https://github.com/purescript/purescript/issues/3157
optimizeUnusedPartialFn :: Expr a -> Expr a
optimizeUnusedPartialFn (Let _
[NonRec _ UnusedIdent _]
(App _ (App _ (Var _ (Qualified _ UnusedIdent)) _) originalCoreFn)) =
originalCoreFn
optimizeUnusedPartialFn e = e

optimizeDataFunctionApply :: Expr a -> Expr a
optimizeDataFunctionApply e = case e of
(App a (App _ (Var _ (Qualified (Just (ModuleName mn)) (Ident fn))) x) y)
Expand Down
4 changes: 0 additions & 4 deletions src/Language/PureScript/CoreImp/Optimizer/TCO.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,6 @@ import Control.Monad.State (State, evalState, get, modify)
import Data.Functor (($>), (<&>))
import qualified Data.Set as S
import Data.Text (Text, pack)
import qualified Language.PureScript.Constants.Prim as C
import Language.PureScript.CoreImp.AST
import Language.PureScript.AST.SourcePos (SourceSpan)
import Safe (headDef, tailSafe)
Expand Down Expand Up @@ -175,9 +174,6 @@ tco = flip evalState 0 . everywhereTopDownM convert where
rootSS = Nothing

collectArgs :: [[AST]] -> AST -> [[AST]]
collectArgs acc (App _ fn []) =
-- count 0-argument applications as single-argument so we get the correct number of args
collectArgs ([Var Nothing C.undefined] : acc) fn
collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
collectArgs acc _ = acc

Expand Down
44 changes: 8 additions & 36 deletions src/Language/PureScript/Linter/Exhaustive.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,12 +15,11 @@ import Control.Applicative
import Control.Arrow (first, second)
import Control.Monad (unless)
import Control.Monad.Writer.Class
import Control.Monad.Supply.Class (MonadSupply, fresh, freshName)
import Control.Monad.Supply.Class (MonadSupply)

import Data.List (foldl', sortOn)
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T

import Language.PureScript.AST.Binders
Expand Down Expand Up @@ -268,49 +267,22 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl'
case rr of
Left Incomplete -> tellIncomplete
_ -> return ()
if null bss
then return expr
return $ if null bss
then expr
else addPartialConstraint (second null (splitAt 5 bss)) expr
where
tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck

-- | We add a Partial constraint by adding a call to the following identity function:
--
-- partial :: forall a. Partial => a -> a
-- | We add a Partial constraint by annotating the expression to have type `Partial => _`.
--
-- The binder information is provided so that it can be embedded in the constraint,
-- and then included in the error message.
addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr
addPartialConstraint (bss, complete) e = do
tyVar <- ("p" <>) . T.pack . show <$> fresh
var <- freshName
return $
Let
FromLet
[ partial var tyVar ]
$ App (Var ss (Qualified Nothing UnusedIdent)) e
addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr
addPartialConstraint (bss, complete) e =
TypedValue True e $
srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) srcTypeWildcard
where
partial :: Text -> Text -> Declaration
partial var tyVar =
ValueDecl (ss, []) UnusedIdent Private []
[MkUnguarded
(TypedValue
True
(Abs (VarBinder ss (Ident var)) (Var ss (Qualified Nothing (Ident var))))
(ty tyVar))
]

ty :: Text -> SourceType
ty tyVar =
srcForAll tyVar
Nothing
( srcConstrainedType
(srcConstraint C.Partial [] [] (Just constraintData))
$ srcTypeApp (srcTypeApp tyFunction (srcTypeVar tyVar)) (srcTypeVar tyVar)
)
Nothing

constraintData :: ConstraintData
constraintData =
PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete
Expand Down
16 changes: 12 additions & 4 deletions src/Language/PureScript/TypeChecker/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -75,6 +75,12 @@ data TypedValue' = TypedValue' Bool Expr SourceType
tvToExpr :: TypedValue' -> Expr
tvToExpr (TypedValue' c e t) = TypedValue c e t

-- | Lookup data about a type class in the @Environment@
lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData
lookupTypeClass name =
let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name
in gets (findClass . typeClasses . checkEnv)

-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
typesOf
Expand Down Expand Up @@ -116,8 +122,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
-- ambiguous types to be inferred if they can be solved by some functional
-- dependency.
conData <- forM unsolved $ \(_, _, con) -> do
let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con)
TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)
TypeClassData{ typeClassDependencies } <- lookupTypeClass $ constraintClass con
let
-- The set of unknowns mentioned in each argument.
unknownsForArg :: [S.Set Int]
Expand Down Expand Up @@ -670,8 +675,11 @@ check' val (ForAll ann ident mbK ty _) = do
| otherwise = val
val' <- tvToExpr <$> check skVal sk
return $ TypedValue' True val' (ForAll ann ident mbK ty (Just scope))
check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _ _) ty) = do
dictName <- freshIdent ("dict" <> className)
check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName className)) _ _ _) ty) = do
TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls
-- An empty class dictionary is never used; see code in `TypeChecker.Entailment`
-- that wraps empty dictionary solutions in `Unused`.
dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> className)
dicts <- newDictionaries [] (Qualified Nothing dictName) con
val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t
Expand Down
11 changes: 4 additions & 7 deletions tests/purs/failing/2806.out
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,13 +9,10 @@ at tests/purs/failing/2806.purs:6:1 - 6:29 (line 6, column 1 - line 6, column 29

Alternatively, add a Partial constraint to the type of the enclosing value.

while applying a function $__unused
of type Partial => t1 -> t1
to argument case e of 
 e | L x <- e -> x
while checking that expression $__unused (case e of 
 e | L x <- e -> x
 ) 
while checking that type Partial => t1
is at least as general as type a0
while checking that expression case e of 
 e | L x <- e -> x
has type a0
in value declaration g

Expand Down
11 changes: 4 additions & 7 deletions tests/purs/failing/NonExhaustivePatGuard.out
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,13 +9,10 @@ at tests/purs/failing/NonExhaustivePatGuard.purs:4:1 - 4:16 (line 4, column 1 -

Alternatively, add a Partial constraint to the type of the enclosing value.

while applying a function $__unused
of type Partial => t0 -> t0
to argument case x of 
 x | 1 <- x -> x
while checking that expression $__unused (case x of 
 x | 1 <- x -> x
 ) 
while checking that type Partial => t0
is at least as general as type Int
while checking that expression case x of 
 x | 1 <- x -> x
has type Int
in value declaration f

Expand Down
13 changes: 4 additions & 9 deletions tests/purs/failing/Superclasses5.out
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,15 +9,10 @@ at tests/purs/failing/Superclasses5.purs:17:1 - 18:18 (line 17, column 1 - line

Alternatively, add a Partial constraint to the type of the enclosing value.

while applying a function $__unused
of type Partial => t0 -> t0
to argument case $0 of 
 [ x ] -> [ su x
 ] 
while inferring the type of $__unused (case $0 of 
 [ x ] -> [ ...
 ] 
 ) 
while checking that expression case $0 of 
 [ x ] -> [ su x
 ] 
has type t0
in value declaration suArray

where t0 is an unknown type
Expand Down