Support local type synonyms natively

Author: rhendric

lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs

@@ -499,50 +499,56 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
   k' s (ConditionGuard e) = ConditionGuard <$> g'' s e
   k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e
 
-data ScopedIdent = LocalIdent Ident | ToplevelIdent Ident
+data ScopedName = LocalName Name | ToplevelName Name
   deriving (Show, Eq, Ord)
 
-inScope :: Ident -> S.Set ScopedIdent -> Bool
-inScope i s = (LocalIdent i `S.member` s) || (ToplevelIdent i `S.member` s)
+inScope' :: (a -> Name) -> a -> S.Set ScopedName -> Bool
+inScope' ctor i s = (LocalName (ctor i) `S.member` s) || (ToplevelName (ctor i) `S.member` s)
+
+inScope :: Ident -> S.Set ScopedName -> Bool
+inScope = inScope' IdentName
+
+typeInScope :: ProperName 'TypeName -> S.Set ScopedName -> Bool
+typeInScope = inScope' TyName
 
 everythingWithScope
   :: forall r
    . (Monoid r)
-  => (S.Set ScopedIdent -> Declaration -> r)
-  -> (S.Set ScopedIdent -> Expr -> r)
-  -> (S.Set ScopedIdent -> Binder -> r)
-  -> (S.Set ScopedIdent -> CaseAlternative -> r)
-  -> (S.Set ScopedIdent -> DoNotationElement -> r)
-  -> ( S.Set ScopedIdent -> Declaration -> r
-     , S.Set ScopedIdent -> Expr -> r
-     , S.Set ScopedIdent -> Binder -> r
-     , S.Set ScopedIdent -> CaseAlternative -> r
-     , S.Set ScopedIdent -> DoNotationElement -> r
+  => (S.Set ScopedName -> Declaration -> r)
+  -> (S.Set ScopedName -> Expr -> r)
+  -> (S.Set ScopedName -> Binder -> r)
+  -> (S.Set ScopedName -> CaseAlternative -> r)
+  -> (S.Set ScopedName -> DoNotationElement -> r)
+  -> ( S.Set ScopedName -> Declaration -> r
+     , S.Set ScopedName -> Expr -> r
+     , S.Set ScopedName -> Binder -> r
+     , S.Set ScopedName -> CaseAlternative -> r
+     , S.Set ScopedName -> DoNotationElement -> r
      )
 everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
   where
-  f'' :: S.Set ScopedIdent -> Declaration -> r
+  f'' :: S.Set ScopedName -> Declaration -> r
   f'' s a = f s a <> f' s a
 
-  f' :: S.Set ScopedIdent -> Declaration -> r
+  f' :: S.Set ScopedName -> Declaration -> r
   f' s (DataBindingGroupDeclaration ds) =
-    let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds))))
+    let s' = S.union s (S.fromList (map ToplevelName (mapMaybe declName (NEL.toList ds))))
     in foldMap (f'' s') ds
   f' s (ValueDecl _ name _ bs val) =
-    let s' = S.insert (ToplevelIdent name) s
+    let s' = S.insert (ToplevelName (IdentName name)) s
         s'' = S.union s' (S.fromList (concatMap localBinderNames bs))
     in foldMap (h'' s') bs <> foldMap (l' s'') val
   f' s (BindingGroupDeclaration ds) =
-    let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds)))
+    let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelName (IdentName name)) ds)))
     in foldMap (\(_, _, val) -> g'' s' val) ds
   f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds
   f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
   f' _ _ = mempty
 
-  g'' :: S.Set ScopedIdent -> Expr -> r
+  g'' :: S.Set ScopedName -> Expr -> r
   g'' s a = g s a <> g' s a
 
-  g' :: S.Set ScopedIdent -> Expr -> r
+  g' :: S.Set ScopedName -> Expr -> r
   g' s (Literal _ l) = lit g'' s l
   g' s (UnaryMinus _ v1) = g'' s v1
   g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
@@ -560,7 +566,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
   g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts
   g' s (TypedValue _ v1 _) = g'' s v1
   g' s (Let _ ds v1) =
-    let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
+    let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
     in foldMap (f'' s') ds <> g'' s' v1
   g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es
   g' s (Ado _ es v1) =
@@ -569,46 +575,46 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
   g' s (PositionedValue _ _ v1) = g'' s v1
   g' _ _ = mempty
 
-  h'' :: S.Set ScopedIdent -> Binder -> r
+  h'' :: S.Set ScopedName -> Binder -> r
   h'' s a = h s a <> h' s a
 
-  h' :: S.Set ScopedIdent -> Binder -> r
+  h' :: S.Set ScopedName -> Binder -> r
   h' s (LiteralBinder _ l) = lit h'' s l
   h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
   h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
   h' s (ParensInBinder b) = h'' s b
-  h' s (NamedBinder _ name b1) = h'' (S.insert (LocalIdent name) s) b1
+  h' s (NamedBinder _ name b1) = h'' (S.insert (LocalName (IdentName name)) s) b1
   h' s (PositionedBinder _ _ b1) = h'' s b1
   h' s (TypedBinder _ b1) = h'' s b1
   h' _ _ = mempty
 
-  lit :: (S.Set ScopedIdent -> a -> r) -> S.Set ScopedIdent -> Literal a -> r
+  lit :: (S.Set ScopedName -> a -> r) -> S.Set ScopedName -> Literal a -> r
   lit go s (ArrayLiteral as) = foldMap (go s) as
   lit go s (ObjectLiteral as) = foldMap (go s . snd) as
   lit _ _ _ = mempty
 
-  i'' :: S.Set ScopedIdent -> CaseAlternative -> r
+  i'' :: S.Set ScopedName -> CaseAlternative -> r
   i'' s a = i s a <> i' s a
 
-  i' :: S.Set ScopedIdent -> CaseAlternative -> r
+  i' :: S.Set ScopedName -> CaseAlternative -> r
   i' s (CaseAlternative bs gs) =
     let s' = S.union s (S.fromList (concatMap localBinderNames bs))
     in foldMap (h'' s) bs <> foldMap (l' s') gs
 
-  j'' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
+  j'' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r)
   j'' s a = let (s', r) = j' s a in (s', j s a <> r)
 
-  j' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r)
+  j' :: S.Set ScopedName -> DoNotationElement -> (S.Set ScopedName, r)
   j' s (DoNotationValue v) = (s, g'' s v)
   j' s (DoNotationBind b v) =
     let s' = S.union (S.fromList (localBinderNames b)) s
     in (s', h'' s b <> g'' s v)
   j' s (DoNotationLet ds) =
-    let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds)))
+    let s' = S.union s (S.fromList (map LocalName (mapMaybe declName ds)))
     in (s', foldMap (f'' s') ds)
   j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
 
-  k' :: S.Set ScopedIdent -> Guard -> (S.Set ScopedIdent, r)
+  k' :: S.Set ScopedName -> Guard -> (S.Set ScopedName, r)
   k' s (ConditionGuard e) = (s, g'' s e)
   k' s (PatternGuard b e) =
     let s' = S.union (S.fromList (localBinderNames b)) s
@@ -619,12 +625,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
     let (s', r) = k' s grd
     in r <> l' s' (GuardedExpr gs e)
 
-  getDeclIdent :: Declaration -> Maybe Ident
-  getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd)
-  getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td)
-  getDeclIdent _ = Nothing
-
-  localBinderNames = map LocalIdent . binderNames
+  localBinderNames = map (LocalName . IdentName) . binderNames
 
 accumTypes
   :: (Monoid r)

lib/purescript-cst/src/Language/PureScript/CST/Convert.hs

@@ -225,6 +225,16 @@ convertLetBinding fileName = \case
   binding@(LetBindingPattern _ a _ b) -> do
     let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
     AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b)
+  binding@(LetBindingType _ (DataHead _ a vars) _ bd) -> do
+    let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
+    AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd)
+  binding@(LetBindingKindSignature _ _ (Labeled name _ ty)) -> do
+    let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
+    AST.KindDeclaration ann AST.TypeSynonymSig (nameValue name) $ convertType fileName ty
+  where
+  goTypeVar = \case
+    TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y)
+    TypeVarName x -> (getIdent $ nameValue x, Nothing)
 
 convertExpr :: forall a. String -> Expr a -> AST.Expr
 convertExpr fileName = go

lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs

@@ -163,6 +163,8 @@ flattenLetBinding = \case
   LetBindingSignature _ a -> flattenLabeled flattenName flattenType a
   LetBindingName _ a -> flattenValueBindingFields a
   LetBindingPattern _ a b c -> flattenBinder a <> pure b <> flattenWhere c
+  LetBindingType _ a b c -> flattenDataHead a <> pure b <> flattenType c
+  LetBindingKindSignature _ a b -> pure a <> flattenLabeled flattenName flattenType b
 
 flattenWhere :: Where a -> DList SourceToken
 flattenWhere (Where a b) =

lib/purescript-cst/src/Language/PureScript/CST/Parser.y

@@ -457,6 +457,8 @@ letBinding :: { LetBinding () }
   | ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) }
   | ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) }
   | binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 }
+  | typeHead '=' type {% checkNoWildcards $3 *> pure (LetBindingType () $1 $2 $3) }
+  | 'type' properName '::' type {% checkNoWildcards $4 *> pure (LetBindingKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }
 
 caseBranch :: { (Separated (Binder ()), Guarded ()) }
   : sep(binder1, ',') guardedCase { ($1, $2) }

lib/purescript-cst/src/Language/PureScript/CST/Positions.hs

@@ -307,6 +307,8 @@ letBindingRange = \case
   LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
   LetBindingName _ a -> valueBindingFieldsRange a
   LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
+  LetBindingType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
+  LetBindingKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)
 
 doStatementRange :: DoStatement a -> TokenRange
 doStatementRange = \case

lib/purescript-cst/src/Language/PureScript/CST/Types.hs

@@ -401,6 +401,8 @@ data LetBinding a
   = LetBindingSignature a (Labeled (Name Ident) (Type a))
   | LetBindingName a (ValueBindingFields a)
   | LetBindingPattern a (Binder a) SourceToken (Where a)
+  | LetBindingType a (DataHead a) SourceToken (Type a)
+  | LetBindingKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a))
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DoBlock a = DoBlock

src/Language/PureScript/Errors.hs

@@ -133,9 +133,10 @@ data SimpleErrorMessage
   | TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName]
   | HiddenConstructors DeclarationRef (Qualified (ProperName 'ClassName))
   | ShadowedName Ident
+  | ShadowedTypeName (ProperName 'TypeName)
   | ShadowedTypeVar Text
   | UnusedTypeVar Text
-  | UnusedName Ident
+  | UnusedName Name
   | UnusedDeclaration Ident
   | WildcardInferredType SourceType Context
   | HoleInferredType Text SourceType Context (Maybe TypeSearch)
@@ -306,6 +307,7 @@ errorCode em = case unwrapErrorMessage em of
   ShadowedName{} -> "ShadowedName"
   UnusedName{} -> "UnusedName"
   UnusedDeclaration{} -> "UnusedDeclaration"
+  ShadowedTypeName{} -> "ShadowedTypeName"
   ShadowedTypeVar{} -> "ShadowedTypeVar"
   UnusedTypeVar{} -> "UnusedTypeVar"
   WildcardInferredType{} -> "WildcardInferredType"
@@ -1055,10 +1057,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
             ]
     renderSimpleErrorMessage (ShadowedName nm) =
       line $ "Name " <> markCode (showIdent nm) <> " was shadowed."
+    renderSimpleErrorMessage (ShadowedTypeName nm) =
+      line $ "Type " <> markCode (runProperName nm) <> " was shadowed."
     renderSimpleErrorMessage (ShadowedTypeVar tv) =
       line $ "Type variable " <> markCode tv <> " was shadowed."
     renderSimpleErrorMessage (UnusedName nm) =
-      line $ "Name " <> markCode (showIdent nm) <> " was introduced but not used."
+      line $ "Name " <> markCode (runName (Qualified Nothing nm)) <> " was introduced but not used."
     renderSimpleErrorMessage (UnusedDeclaration nm) =
       line $ "Declaration " <> markCode (showIdent nm) <> " was not used, and is not exported."
     renderSimpleErrorMessage (UnusedTypeVar tv) =

src/Language/PureScript/Ide/Usage.hs

@@ -141,7 +141,7 @@ applySearch module_ search =
       P.Var sp i
         | Just ideValue <- preview _IdeDeclValue (P.disqualify search)
         , P.isQualified search
-          || not (P.LocalIdent (_ideValueIdent ideValue) `Set.member` scope) ->
+          || not (P.LocalName (P.IdentName (_ideValueIdent ideValue)) `Set.member` scope) ->
           [sp | map P.runIdent i == map identifierFromIdeDeclaration search]
       P.Constructor sp name
         | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search ->