Skip to content

Commit 4d21526

Browse files
mitchellwrosenmitchellwrosen
committed
misc cleanup
1 parent c3ced32 commit 4d21526

File tree

1 file changed

+159
-163
lines changed

1 file changed

+159
-163
lines changed

‎parser-typechecker/src/Unison/Syntax/TermParser.hs

Lines changed: 159 additions & 163 deletions
Original file line numberDiff line numberDiff line change
@@ -220,7 +220,7 @@ matchCases = sepBy semi matchCase <&> \cases_ -> [(n, c) | (n, cs) <- cases_, c
220220
-- (42, x) -> ...
221221
matchCase :: (Monad m, Var v) => P v m (Int, [Term.MatchCase Ann (Term v Ann)])
222222
matchCase = do
223-
pats <- sepBy1 (label "\",\"" $ reserved ",") parsePattern
223+
pats <- sepBy1 (label "\",\"" $ reserved ",") (parsePattern >>= bindConstructorsInPattern)
224224
let boundVars' = [v | (_, vs) <- pats, (_ann, v) <- vs]
225225
pat = case fst <$> pats of
226226
[p] -> p
@@ -245,165 +245,8 @@ matchCase = do
245245
let mk (guard, t) = Term.MatchCase pat (fmap (absChain boundVars') guard) (absChain boundVars' t)
246246
pure $ (length pats, mk <$> guardsAndBlocks)
247247

248-
parsePattern :: (Monad m, Var v) => P v m (Pattern.Pattern Ann, [(Ann, v)])
248+
parsePattern :: forall m v. (Monad m, Var v) => P v m (Syntax.Pattern.Pattern v)
249249
parsePattern =
250-
parsePattern2 >>= bindConstructorsInPattern
251-
252-
bindConstructorsInPattern :: (Monad m, Var v) => Syntax.Pattern.Pattern v -> P v m (Pattern.Pattern Ann, [(Ann, v)])
253-
bindConstructorsInPattern =
254-
fmap (over _2 (\f -> (map tokenToPair (f [])))) . runWriterT . bindConstructorsInPattern1
255-
256-
bindConstructorsInPattern1 ::
257-
forall m v.
258-
(Monad m, Var v) =>
259-
Syntax.Pattern.Pattern v ->
260-
WriterT ([L.Token v] -> [L.Token v]) (P v m) (Pattern.Pattern Ann)
261-
bindConstructorsInPattern1 = \case
262-
Syntax.Pattern.As pos v lpat -> do
263-
tell (v :)
264-
pat <- bindConstructorsInPattern1 lpat
265-
pure (Pattern.As pos pat)
266-
Syntax.Pattern.Boolean pos b -> pure (Pattern.Boolean pos b)
267-
Syntax.Pattern.Char pos c -> pure (Pattern.Char pos c)
268-
Syntax.Pattern.Constructor pos name pats ->
269-
Pattern.Constructor pos
270-
<$> lift (bindConstructor CT.Data name)
271-
<*> traverse bindConstructorsInPattern1 pats
272-
Syntax.Pattern.EffectBind pos name pats cont ->
273-
Pattern.EffectBind pos
274-
<$> lift (bindConstructor CT.Effect name)
275-
<*> traverse bindConstructorsInPattern1 pats
276-
<*> bindConstructorsInPattern1 cont
277-
Syntax.Pattern.EffectPure pos lpat -> Pattern.EffectPure pos <$> bindConstructorsInPattern1 lpat
278-
Syntax.Pattern.Float pos n -> pure (Pattern.Float pos n)
279-
Syntax.Pattern.Int pos n -> pure (Pattern.Int pos n)
280-
Syntax.Pattern.Nat pos n -> pure (Pattern.Nat pos n)
281-
Syntax.Pattern.Pair _ lpat1 lpat2 ->
282-
( \pat1 pat2 ->
283-
Pattern.Constructor
284-
(ann pat1 <> ann pat2)
285-
(ConstructorReference DD.pairRef 0)
286-
[pat1, pat2]
287-
)
288-
<$> bindConstructorsInPattern1 lpat1
289-
<*> bindConstructorsInPattern1 lpat2
290-
Syntax.Pattern.SequenceLiteral pos pats -> Pattern.SequenceLiteral pos <$> traverse bindConstructorsInPattern1 pats
291-
Syntax.Pattern.SequenceOp pos lpat1 op lpat2 ->
292-
Pattern.SequenceOp pos
293-
<$> bindConstructorsInPattern1 lpat1
294-
<*> pure case op of
295-
Syntax.Pattern.Concat -> Pattern.Concat
296-
Syntax.Pattern.Cons -> Pattern.Cons
297-
Syntax.Pattern.Snoc -> Pattern.Snoc
298-
<*> bindConstructorsInPattern1 lpat2
299-
Syntax.Pattern.Text pos t -> pure (Pattern.Text pos t)
300-
Syntax.Pattern.Unbound pos -> pure (Pattern.Unbound pos)
301-
Syntax.Pattern.Unit pos -> pure (Pattern.Constructor pos (ConstructorReference DD.unitRef 0) [])
302-
-- Not awesome: something can be at once a syntactically valid nullary constructor and a syntactically valid
303-
-- variable. We currently handle this by simply looking in the namespace to determine whether it's a
304-
-- constructor, and if it isn't, we treat it as a variable.
305-
Syntax.Pattern.VarOrNullaryConstructor pos name ->
306-
lift (maybeBindLocalConstructor CT.Data (L.payload name)) >>= \case
307-
Just localCtor -> pure (Pattern.Constructor pos localCtor [])
308-
Nothing -> do
309-
names <- asks names
310-
let failure :: ResolutionError Referent -> P v m a
311-
failure err =
312-
failCommitted $
313-
ResolutionFailures
314-
[ TermResolutionFailure
315-
(HQ.NameOnly (L.payload name))
316-
(ann name)
317-
err
318-
]
319-
case Names.lookupHQPattern Names.IncludeSuffixes (HQ.NameOnly (L.payload name)) CT.Data names of
320-
constructors
321-
| Set.size constructors == 1 -> pure (Pattern.Constructor pos (Set.findMin constructors) [])
322-
| Set.null constructors ->
323-
-- Not great thing alert :alarm: :alarm:
324-
-- This is a syntactically valid variable, however, if it begins with a capital letter, we choose to
325-
-- consider it a constructor-out-of-scope, since that's probably what the user meant.
326-
if lastSegmentBeginsWithCapitalLetter
327-
then lift (failure NotFound)
328-
else do
329-
tell ((Name.toVar <$> name) :)
330-
pure (Pattern.Var pos)
331-
| otherwise ->
332-
lift $
333-
failure
334-
( Ambiguous
335-
names
336-
(Set.map (\ref -> Referent.Con ref CT.Data) constructors)
337-
Set.empty
338-
)
339-
where
340-
lastSegmentBeginsWithCapitalLetter :: Bool
341-
lastSegmentBeginsWithCapitalLetter =
342-
not (Char.isLower (Text.head (NameSegment.toUnescapedText (Name.lastSegment (L.payload name)))))
343-
where
344-
bindConstructor :: CT.ConstructorType -> L.Token (HQ.HashQualified Name) -> P v m ConstructorReference
345-
bindConstructor ct hqName = do
346-
-- First, if:
347-
--
348-
-- * The token isn't hash-qualified (e.g. "Foo.Bar")
349-
-- * We're under a namespace directive (e.g. "baz")
350-
-- * There's an exact match for a locally-bound constructor (e.g. "baz.Foo.Bar")
351-
--
352-
-- Then:
353-
--
354-
-- * Use that constructor reference (duh)
355-
--
356-
-- Else:
357-
--
358-
-- * Fall through to the normal logic of looking the constructor name up in all of the names (which includes
359-
-- the locally-bound constructors).
360-
maybeLocalCtor <-
361-
case L.payload hqName of
362-
HQ.NameOnly name -> maybeBindLocalConstructor ct name
363-
_ -> pure Nothing
364-
365-
case maybeLocalCtor of
366-
Just localCtor -> pure localCtor
367-
Nothing -> do
368-
names <- asks names
369-
case Names.lookupHQPattern Names.IncludeSuffixes (L.payload hqName) ct names of
370-
s
371-
| Set.size s == 1 -> pure (Set.findMin s)
372-
| otherwise ->
373-
failCommitted $
374-
ResolutionFailures
375-
[ TermResolutionFailure
376-
(L.payload hqName)
377-
(ann hqName)
378-
if Set.null s
379-
then NotFound
380-
else
381-
Ambiguous
382-
names
383-
(Set.map (\ref -> Referent.Con ref ct) s)
384-
-- Eh, here we're saying there are no "local" constructors – they're all from "the
385-
-- namespace". That's not necessarily true, but it doesn't (currently) affect the error
386-
-- message any, and we have already parsed and hashed local constructors (so they aren't
387-
-- really different from namespace constructors).
388-
Set.empty
389-
]
390-
391-
maybeBindLocalConstructor :: CT.ConstructorType -> Name -> P v m (Maybe ConstructorReference)
392-
maybeBindLocalConstructor ct name =
393-
asks maybeNamespace >>= \case
394-
Nothing -> pure Nothing
395-
Just namespace -> do
396-
localNames <- asks localNamespacePrefixedTypesAndConstructors
397-
pure case Names.lookupHQPattern Names.ExactName (HQ.NameOnly (Name.joinDot namespace name)) ct localNames of
398-
refs
399-
| Set.null refs -> Nothing
400-
-- 2+ name case is impossible: we looked up exact names in the locally-bound names. Two bindings
401-
-- with the same name would have been a parse error. So, just take the minimum element from the set,
402-
-- which we know is a singleton.
403-
| otherwise -> Just (Set.findMin refs)
404-
405-
parsePattern2 :: forall m v. (Monad m, Var v) => P v m (Syntax.Pattern.Pattern v)
406-
parsePattern2 =
407250
label "pattern" pRoot
408251
where
409252
pRoot :: P v m (Syntax.Pattern.Pattern v)
@@ -492,7 +335,7 @@ parsePattern2 =
492335

493336
pParenOrTuple :: P v m (Syntax.Pattern.Pattern v)
494337
pParenOrTuple = do
495-
snd <$> tupleOrParenthesized parsePattern2 Syntax.Pattern.Unit mkPair
338+
snd <$> tupleOrParenthesized parsePattern Syntax.Pattern.Unit mkPair
496339
where
497340
mkPair :: Syntax.Pattern.Pattern v -> Syntax.Pattern.Pattern v -> Syntax.Pattern.Pattern v
498341
mkPair p1 p2 =
@@ -535,12 +378,12 @@ parsePattern2 =
535378
name <- hqPrefixId
536379
patterns <- many pLeaf
537380
_ <- reserved "->"
538-
cont <- parsePattern2
381+
cont <- parsePattern
539382
pure (Syntax.Pattern.EffectBind (ann name <> ann cont) name patterns cont)
540383

541384
pEffectPure :: P v m (Syntax.Pattern.Pattern v)
542385
pEffectPure =
543-
parsePattern2 <&> \pat -> Syntax.Pattern.EffectPure (ann pat) pat
386+
parsePattern <&> \pat -> Syntax.Pattern.EffectPure (ann pat) pat
544387

545388
-- Parse an "HQ-namey", which could either definitely be a nullary constructor (because it's either hash-only or
546389
-- hash-qualified or symboly), or either a variable or nullary constructor (because it's a wordy name-only). And if
@@ -558,6 +401,159 @@ parsePattern2 =
558401
p <- pLeaf
559402
pure (Syntax.Pattern.As (ann tok <> ann p) (Name.toVar name <$ tok) p)
560403

404+
bindConstructorsInPattern :: (Monad m, Var v) => Syntax.Pattern.Pattern v -> P v m (Pattern.Pattern Ann, [(Ann, v)])
405+
bindConstructorsInPattern =
406+
fmap (over _2 (\f -> (map tokenToPair (f [])))) . runWriterT . bindConstructorsInPattern1
407+
where
408+
bindConstructorsInPattern1 ::
409+
forall m v.
410+
(Monad m, Var v) =>
411+
Syntax.Pattern.Pattern v ->
412+
WriterT ([L.Token v] -> [L.Token v]) (P v m) (Pattern.Pattern Ann)
413+
bindConstructorsInPattern1 = \case
414+
Syntax.Pattern.As pos v lpat -> do
415+
tell (v :)
416+
pat <- bindConstructorsInPattern1 lpat
417+
pure (Pattern.As pos pat)
418+
Syntax.Pattern.Boolean pos b -> pure (Pattern.Boolean pos b)
419+
Syntax.Pattern.Char pos c -> pure (Pattern.Char pos c)
420+
Syntax.Pattern.Constructor pos name pats ->
421+
Pattern.Constructor pos
422+
<$> lift (bindConstructor CT.Data name)
423+
<*> traverse bindConstructorsInPattern1 pats
424+
Syntax.Pattern.EffectBind pos name pats cont ->
425+
Pattern.EffectBind pos
426+
<$> lift (bindConstructor CT.Effect name)
427+
<*> traverse bindConstructorsInPattern1 pats
428+
<*> bindConstructorsInPattern1 cont
429+
Syntax.Pattern.EffectPure pos lpat -> Pattern.EffectPure pos <$> bindConstructorsInPattern1 lpat
430+
Syntax.Pattern.Float pos n -> pure (Pattern.Float pos n)
431+
Syntax.Pattern.Int pos n -> pure (Pattern.Int pos n)
432+
Syntax.Pattern.Nat pos n -> pure (Pattern.Nat pos n)
433+
Syntax.Pattern.Pair _ lpat1 lpat2 ->
434+
( \pat1 pat2 ->
435+
Pattern.Constructor
436+
(ann pat1 <> ann pat2)
437+
(ConstructorReference DD.pairRef 0)
438+
[pat1, pat2]
439+
)
440+
<$> bindConstructorsInPattern1 lpat1
441+
<*> bindConstructorsInPattern1 lpat2
442+
Syntax.Pattern.SequenceLiteral pos pats -> Pattern.SequenceLiteral pos <$> traverse bindConstructorsInPattern1 pats
443+
Syntax.Pattern.SequenceOp pos lpat1 op lpat2 ->
444+
Pattern.SequenceOp pos
445+
<$> bindConstructorsInPattern1 lpat1
446+
<*> pure case op of
447+
Syntax.Pattern.Concat -> Pattern.Concat
448+
Syntax.Pattern.Cons -> Pattern.Cons
449+
Syntax.Pattern.Snoc -> Pattern.Snoc
450+
<*> bindConstructorsInPattern1 lpat2
451+
Syntax.Pattern.Text pos t -> pure (Pattern.Text pos t)
452+
Syntax.Pattern.Unbound pos -> pure (Pattern.Unbound pos)
453+
Syntax.Pattern.Unit pos -> pure (Pattern.Constructor pos (ConstructorReference DD.unitRef 0) [])
454+
-- Not awesome: something can be at once a syntactically valid nullary constructor and a syntactically valid
455+
-- variable. We currently handle this by simply looking in the namespace to determine whether it's a
456+
-- constructor, and if it isn't, we treat it as a variable.
457+
Syntax.Pattern.VarOrNullaryConstructor pos name ->
458+
lift (maybeBindLocalConstructor CT.Data (L.payload name)) >>= \case
459+
Just localCtor -> pure (Pattern.Constructor pos localCtor [])
460+
Nothing -> do
461+
names <- asks names
462+
let failure :: ResolutionError Referent -> P v m a
463+
failure err =
464+
failCommitted $
465+
ResolutionFailures
466+
[ TermResolutionFailure
467+
(HQ.NameOnly (L.payload name))
468+
(ann name)
469+
err
470+
]
471+
case Names.lookupHQPattern Names.IncludeSuffixes (HQ.NameOnly (L.payload name)) CT.Data names of
472+
constructors
473+
| Set.size constructors == 1 -> pure (Pattern.Constructor pos (Set.findMin constructors) [])
474+
| Set.null constructors ->
475+
-- Not great thing alert :alarm: :alarm:
476+
-- This is a syntactically valid variable, however, if it begins with a capital letter, we choose to
477+
-- consider it a constructor-out-of-scope, since that's probably what the user meant.
478+
if lastSegmentBeginsWithCapitalLetter
479+
then lift (failure NotFound)
480+
else do
481+
tell ((Name.toVar <$> name) :)
482+
pure (Pattern.Var pos)
483+
| otherwise ->
484+
lift $
485+
failure
486+
( Ambiguous
487+
names
488+
(Set.map (\ref -> Referent.Con ref CT.Data) constructors)
489+
Set.empty
490+
)
491+
where
492+
lastSegmentBeginsWithCapitalLetter :: Bool
493+
lastSegmentBeginsWithCapitalLetter =
494+
not (Char.isLower (Text.head (NameSegment.toUnescapedText (Name.lastSegment (L.payload name)))))
495+
where
496+
bindConstructor :: CT.ConstructorType -> L.Token (HQ.HashQualified Name) -> P v m ConstructorReference
497+
bindConstructor ct hqName = do
498+
-- First, if:
499+
--
500+
-- * The token isn't hash-qualified (e.g. "Foo.Bar")
501+
-- * We're under a namespace directive (e.g. "baz")
502+
-- * There's an exact match for a locally-bound constructor (e.g. "baz.Foo.Bar")
503+
--
504+
-- Then:
505+
--
506+
-- * Use that constructor reference (duh)
507+
--
508+
-- Else:
509+
--
510+
-- * Fall through to the normal logic of looking the constructor name up in all of the names (which includes
511+
-- the locally-bound constructors).
512+
maybeLocalCtor <-
513+
case L.payload hqName of
514+
HQ.NameOnly name -> maybeBindLocalConstructor ct name
515+
_ -> pure Nothing
516+
517+
case maybeLocalCtor of
518+
Just localCtor -> pure localCtor
519+
Nothing -> do
520+
names <- asks names
521+
case Names.lookupHQPattern Names.IncludeSuffixes (L.payload hqName) ct names of
522+
s
523+
| Set.size s == 1 -> pure (Set.findMin s)
524+
| otherwise ->
525+
failCommitted $
526+
ResolutionFailures
527+
[ TermResolutionFailure
528+
(L.payload hqName)
529+
(ann hqName)
530+
if Set.null s
531+
then NotFound
532+
else
533+
Ambiguous
534+
names
535+
(Set.map (\ref -> Referent.Con ref ct) s)
536+
-- Eh, here we're saying there are no "local" constructors – they're all from "the
537+
-- namespace". That's not necessarily true, but it doesn't (currently) affect the error
538+
-- message any, and we have already parsed and hashed local constructors (so they aren't
539+
-- really different from namespace constructors).
540+
Set.empty
541+
]
542+
543+
maybeBindLocalConstructor :: CT.ConstructorType -> Name -> P v m (Maybe ConstructorReference)
544+
maybeBindLocalConstructor ct name =
545+
asks maybeNamespace >>= \case
546+
Nothing -> pure Nothing
547+
Just namespace -> do
548+
localNames <- asks localNamespacePrefixedTypesAndConstructors
549+
pure case Names.lookupHQPattern Names.ExactName (HQ.NameOnly (Name.joinDot namespace name)) ct localNames of
550+
refs
551+
| Set.null refs -> Nothing
552+
-- 2+ name case is impossible: we looked up exact names in the locally-bound names. Two bindings
553+
-- with the same name would have been a parse error. So, just take the minimum element from the set,
554+
-- which we know is a singleton.
555+
| otherwise -> Just (Set.findMin refs)
556+
561557
lam :: (Var v) => TermP v m -> TermP v m
562558
lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved "->") <*> p
563559
where
@@ -1365,7 +1361,7 @@ destructuringBind = do
13651361
-- (Some 42)
13661362
-- vs
13671363
-- (Some 42) = List.head elems
1368-
pat <- P.try (parsePattern2 <* P.lookAhead (openBlockWith "="))
1364+
pat <- P.try (parsePattern <* P.lookAhead (openBlockWith "="))
13691365
(p, boundVars) <- over (_2 . mapped) snd <$> bindConstructorsInPattern pat
13701366
(_spanAnn, scrute) <- layoutBlock "=" -- Dwight K. Scrute ("The People's Scrutinee")
13711367
let guard = Nothing

0 commit comments

Comments
 (0)