Skip to content

Prevent typeclass instance self-reference (#3429). #3638

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

Open
matthew-hilty wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Prevent typeclass instance self-reference (#3429). #3638

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
f914340
Prevent typeclass instance self-reference (#3429).
matthew-hilty May 13, 2019
c3757c0
Document 'everythingWithContextOnValues' per suggestion.
matthew-hilty Jun 22, 2019
2865ce2
Merge branch 'master' into fix-3429--uncaught-instance-self-reference
matthew-hilty Aug 13, 2019
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
1 change: 1 addition & 0 deletions CONTRIBUTORS.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -135,6 +135,7 @@ If you would prefer to use different terms, please use the section below instead
| [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license](http://opensource.org/licenses/MIT) |
| [@dyerw](https://github.com/dyerw) | Liam Dyer | [MIT license](http://opensource.org/licenses/MIT) |
| [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license](http://opensource.org/licenses/MIT) |
| [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license](http://opensource.org/licenses/MIT) |

### Contributors using Modified Terms

Expand Down
21 changes: 21 additions & 0 deletions src/Language/PureScript/AST/Declarations.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -64,6 +64,9 @@ onTypeSearchTypesM :: (Applicative m) => (SourceType -> m SourceType) -> TypeSea
onTypeSearchTypesM f (TSAfter i r) = TSAfter <$> traverse (traverse f) i <*> traverse (traverse (traverse f)) r
onTypeSearchTypesM _ (TSBefore env) = pure (TSBefore env)

data DictMemberType = Fn | NonFn
deriving (Eq, Ord, Show)

-- | A type of error messages
data SimpleErrorMessage
= ModuleNotFound ModuleName
Expand Down Expand Up @@ -101,6 +104,8 @@ data SimpleErrorMessage
| InvalidDoBind
| InvalidDoLet
| CycleInDeclaration Ident
| CycleInDictDeclaration Ident [(Ident, SourceSpan, DictMemberType)]
| MissingEtaExpansion Ident
| CycleInTypeSynonym (Maybe (ProperName 'TypeName))
| CycleInTypeClassDeclaration [Qualified (ProperName 'ClassName)]
| CycleInModules [ModuleName]
Expand Down Expand Up @@ -477,6 +482,22 @@ getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
getValueDeclaration (ValueDeclaration d) = Just d
getValueDeclaration _ = Nothing

isDictExpr :: Expr -> Bool
isDictExpr expr = case stripTypedAndPositioned expr of
TypeClassDictionaryConstructorApp _ _ -> True
Abs _ expr' -> isDictExpr expr'
_ -> False

getDictDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
getDictDeclaration (ValueDeclaration d@(ValueDeclarationData _ _ Private _ [MkUnguarded expr]))
| isDictExpr expr = Just d
getDictDeclaration _ = Nothing

stripTypedAndPositioned :: Expr -> Expr
stripTypedAndPositioned (TypedValue _ e _) = stripTypedAndPositioned e
stripTypedAndPositioned (PositionedValue _ _ e) = stripTypedAndPositioned e
stripTypedAndPositioned e = e

pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
pattern ValueDecl sann ident name binders expr
= ValueDeclaration (ValueDeclarationData sann ident name binders expr)
Expand Down
59 changes: 57 additions & 2 deletions src/Language/PureScript/AST/Traversals.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -329,13 +329,44 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j')
k' (ConditionGuard e) = g' e
k' (PatternGuard b e) = h' b <>. g' e

-- |
-- A fold for paramorphisms associated with (1) an initial object represented
-- by the coproduct 'Node'
-- @
-- data Node
-- = A Declaration
-- | NonLiteral Expr
-- | Literal Expr
-- | B Binder
-- | C CaseAlternative
-- | D DoNotationElement
-- @
-- and (2) the functorial context
-- > type Context s r = (s, r, r -> r -> r, s -> Node -> (s, r))
--
-- Given an initial state, a default output value, a binary action on the
-- output type, and six independent state-transition transformers (one each for
-- 'Declaration's, 'Binder's, 'CaseAlternative's, and 'DoNotationElement's; and
-- two for 'Expr's), determine five corresponding mutually recursive data-
-- gathering functions that generate "measurements" of type 'r' for values of
-- any of the constituent types of the coproduct 'Node'.
--
-- Two input functions for 'Expr' are required in order to allow distinguishing
-- of values inside 'Literal' 'Expr's from values independent of literal objects
-- and arrays. (The function 'immediateLitIdentsAndAllOtherIdents' in module
-- 'Language.PureScript.Sugar.BindingGroups' is an example of a client for
-- this feature.)
--
everythingWithContextOnValues
:: forall s r
. s
-> r
-> (r -> r -> r)
-> (s -> Declaration -> (s, r))
-> (s -> Expr -> (s, r))
-- ^ Transformer of 'Expr' nodes without 'Literal' ancestors
-> (s -> Expr -> (s, r))

@natefaubion natefaubion Jun 16, 2019 •
edited
Loading

Copy link
Copy Markdown
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Can we document the change to this traversal in a comment? It wouldn't be clear to me just seeing this signature why we have a seemingly duplicated parameter like this that isn't present in other traversals.

@matthew-hilty matthew-hilty Jun 18, 2019

Copy link
Copy Markdown
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, that makes sense. Documentation would definitely be helpful here.

Any thoughts on the following documentation attempt? Suggestions for making it clearer (more accurate) (more relevant) for example?

-- |
-- A fold for paramorphisms associated with (1) an initial object represented
-- by the coproduct 'Node'
-- @
--   data Node
--     = A Declaration
--     | NonLiteral Expr
--     | Literal Expr
--     | B Binder
--     | C CaseAlternative
--     | D DoNotationElement
-- @
-- and (2) the functorial context
-- > type Context s r = (s, r, r -> r -> r, s -> Node -> (s, r))
--
-- Given an initial state, a default output value, a binary action on the
-- output type, and six independent state-transition transformers (one each for
-- 'Declaration's, 'Binder's, 'CaseAlternative's, and 'DoNotationElement's; and
-- two for 'Expr's), determine five corresponding mutually recursive data-
-- gathering functions that generate "measurements" of type 'r' for values of
-- any of the constituent types of the coproduct 'Node'.
--
-- Two input functions for 'Expr' are required in order to allow distinguishing
-- of values inside 'Literal' 'Expr's from values independent of literal objects
-- and arrays. (The function 'immediateLitIdentsAndAllOtherIdents' in module
-- 'Language.PureScript.Sugar.BindingGroups' is an example of a client for
-- this feature.)
--
everythingWithContextOnValues
  :: forall s r
   . s
  -> r
  -> (r -> r -> r)
  -> (s -> Declaration       -> (s, r))
  -> (s -> Expr              -> (s, r))
  -- ^ Transformer of 'Expr' nodes without 'Literal' ancestors
  -> (s -> Expr              -> (s, r))
  -- ^ Transformer of 'Expr' nodes strictly dominated by a 'Literal' 'Expr'
  -> (s -> Binder            -> (s, r))
  -> (s -> CaseAlternative   -> (s, r))
  -> (s -> DoNotationElement -> (s, r))
  -> ( Declaration       -> r
     , Expr              -> r
     , Binder            -> r
     , CaseAlternative   -> r
     , DoNotationElement -> r)

(Thanks for your feedback by the way.)

@rhendric rhendric Sep 2, 2020

Copy link
Copy Markdown
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I realize it's probably a little obnoxious to necro-bump a PR without actually reviewing the important part of it, so sorry; whether this approach is a good idea or not is above my pay grade. But I wanted to register my confusion with respect to this change to everythingWithContextOnValues. Why is this necessary? Couldn't the condition of being inside a Literal be included as part of the context? I realize that would make the implementation of immediateLitIdentsAndAllOtherIdents more complicated but I don't (yet?) buy that this belongs in a generic traversal.

-- ^ Transformer of 'Expr' nodes strictly dominated by a 'Literal' 'Expr'
-> (s -> Binder -> (s, r))
-> (s -> CaseAlternative -> (s, r))
-> (s -> DoNotationElement -> (s, r))
Expand All @@ -344,7 +375,8 @@ everythingWithContextOnValues
, Binder -> r
, CaseAlternative -> r
, DoNotationElement -> r)
everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
everythingWithContextOnValues s0 r0 (<>.) f g gLit h i j =
(f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
where

f'' :: s -> Declaration -> r
Expand All @@ -362,7 +394,7 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i
g'' s v = let (s', r) = g s v in r <>. g' s' v

g' :: s -> Expr -> r
g' s (Literal _ l) = lit g'' s l
g' s (Literal _ l) = lit gLit'' s l
g' s (UnaryMinus _ v1) = g'' s v1
g' s (BinaryNoParens op v1 v2) = g'' s op <>. g'' s v1 <>. g'' s v2
g' s (Parens v1) = g'' s v1
Expand All @@ -382,6 +414,29 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i
g' s (PositionedValue _ _ v1) = g'' s v1
g' _ _ = r0

gLit'' :: s -> Expr -> r
gLit'' s v = let (s', r) = gLit s v in r <>. gLit' s' v

gLit' :: s -> Expr -> r
gLit' s (Literal _ l) = lit gLit'' s l
gLit' s (UnaryMinus _ v1) = gLit'' s v1
gLit' s (BinaryNoParens op v1 v2) = gLit'' s op <>. gLit'' s v1 <>. gLit'' s v2
gLit' s (Parens v1) = gLit'' s v1
gLit' s (TypeClassDictionaryConstructorApp _ v1) = gLit'' s v1
gLit' s (Accessor _ v1) = gLit'' s v1
gLit' s (ObjectUpdate obj vs) = foldl (<>.) (gLit'' s obj) (fmap (gLit'' s . snd) vs)
gLit' s (ObjectUpdateNested obj vs) = foldl (<>.) (gLit'' s obj) (fmap (gLit'' s) vs)
gLit' s (Abs binder v1) = h'' s binder <>. gLit'' s v1
gLit' s (App v1 v2) = gLit'' s v1 <>. gLit'' s v2
gLit' s (IfThenElse v1 v2 v3) = gLit'' s v1 <>. gLit'' s v2 <>. gLit'' s v3
gLit' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (gLit'' s) vs)) (fmap (i'' s) alts)
gLit' s (TypedValue _ v1 _) = gLit'' s v1
gLit' s (Let _ ds v1) = foldl (<>.) r0 (fmap (f'' s) ds) <>. gLit'' s v1
gLit' s (Do _ es) = foldl (<>.) r0 (fmap (j'' s) es)
gLit' s (Ado _ es v1) = foldl (<>.) r0 (fmap (j'' s) es) <>. gLit'' s v1
gLit' s (PositionedValue _ _ v1) = gLit'' s v1
gLit' _ _ = r0

h'' :: s -> Binder -> r
h'' s b = let (s', r) = h s b in r <>. h' s' b

Expand Down
8 changes: 8 additions & 0 deletions src/Language/PureScript/Environment.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -359,6 +359,14 @@ isTypeOrApplied :: Type a -> Type b -> Bool
isTypeOrApplied t1 (TypeApp _ t2 _) = eqType t1 t2
isTypeOrApplied t1 t2 = eqType t1 t2

isFunctionType :: SourceType -> Bool
isFunctionType = eqType tyFunction . stripForAllAndTypeApp

stripForAllAndTypeApp :: SourceType -> SourceType
stripForAllAndTypeApp (ForAll _ _ _ st _) = stripForAllAndTypeApp st
stripForAllAndTypeApp (TypeApp _ st _) = stripForAllAndTypeApp st
stripForAllAndTypeApp st = st

-- | Smart constructor for function types
function :: SourceType -> SourceType -> SourceType
function t1 t2 = TypeApp nullSourceAnn (TypeApp nullSourceAnn tyFunction t1) t2
Expand Down
51 changes: 50 additions & 1 deletion src/Language/PureScript/Errors.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,9 @@ import qualified Text.Parsec.Error as PE
import Text.Parsec.Error (Message(..))
import qualified Text.PrettyPrint.Boxes as Box

noErrors :: MultipleErrors
noErrors = MultipleErrors []

newtype ErrorSuggestion = ErrorSuggestion Text

-- | Get the source span for an error
Expand Down Expand Up @@ -111,6 +114,8 @@ errorCode em = case unwrapErrorMessage em of
InvalidDoBind -> "InvalidDoBind"
InvalidDoLet -> "InvalidDoLet"
CycleInDeclaration{} -> "CycleInDeclaration"
CycleInDictDeclaration{} -> "CycleInDictDeclaration"
MissingEtaExpansion{} -> "MissingEtaExpansion"
CycleInTypeSynonym{} -> "CycleInTypeSynonym"
CycleInTypeClassDeclaration{} -> "CycleInTypeClassDeclaration"
CycleInModules{} -> "CycleInModules"
Expand Down Expand Up @@ -574,7 +579,47 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
, indent $ line $ displaySourceSpan relPath ss
]
renderSimpleErrorMessage (CycleInDeclaration nm) =
line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed."
line $ "The value of " <> markCode (showIdent nm) <> " is undefined here because of cyclical dependencies, so this reference is not allowed."
renderSimpleErrorMessage (CycleInDictDeclaration inst fields) =
let label' dmt = if dmt == Fn then "function " else "value "
label (i, ss, dmt) =
indent' . line $
label' dmt <> markCode (showIdent i) <> " at " <> displaySourceSpan relPath ss
prelude = line $ "The definition of instance " <> markCode (showIdent inst) <> " is invalid because of cyclical dependencies."
addendum =
[ line ""
, line $ "Note that cycles in the member functions of " <> markCode (showIdent inst) <> " may lead to non-terminating runtime behavior."
, line ""
, line $ "Consider replacing the functions' circular dependencies with independent terms."
, line ""
, line $ "If their definitions cannot be rewritten, eta-expansion is necessary to accommodate purescript's non-strict style of evaluation."
]
addendum' = if (any (\(_, _, dmt) -> dmt == Fn) fields)
then addendum
else []
in case fields of
[] -> prelude
[field] ->
paras $ [ prelude
, line ""
, line $ "In particular, its member"
, label field
, line $ "implicitly references the instance itself."
] ++ addendum'
_ ->
paras $ [ prelude
, line ""
, line $ "In particular, its following members implicitly reference the instance itself."
] ++ map label fields ++ addendum'
renderSimpleErrorMessage (MissingEtaExpansion ident) =
paras [ line $ "A cycle appears in the definition of function " <> markCode (showIdent ident) <> "."
, line ""
, line $ "Note that cycles in functions may lead to non-terminating runtime behavior."
, line ""
, line $ "Consider replacing the circular dependencies in the definition of " <> markCode (showIdent ident) <> " with independent terms."
, line ""
, line "If the definition cannot be rewritten, eta-expansion is necessary to accommodate purescript's non-strict style of evaluation."
]
renderSimpleErrorMessage (CycleInModules mns) =
case mns of
[mn] ->
Expand Down Expand Up @@ -1438,6 +1483,10 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
indent :: Box.Box -> Box.Box
indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2

-- | Indent to the right without vertical padding.
indent' :: Box.Box -> Box.Box
indent' = Box.moveRight 2

line :: Text -> Box.Box
line = Box.text . T.unpack

Expand Down
Loading