8c324a0 · rowtype-yoga/purescript-native

examples/docs/src/TypeClassWithFunDeps.pursnew file+5

compare with golang

unifiedsplit

@@ -0,0 +1,5 @@

1+

2+module TypeClassWithFunDeps where

3+

4+class TypeClassWithFunDeps a b c d e | a b -> c, c -> d e where

5+ aMember :: a

psc-docs/Tags.hs+1−1

@@ -1,6 +1,6 @@

1module Tags where

2

3−import Control.Arrow (first)

3+import Control.Arrow (first)

4import qualified Data.Text as T

5import qualified Language.PureScript as P

6

src/Language/PureScript/Docs/Convert/ReExports.hs+1−1

@@ -503,7 +503,7 @@ internalErrorInModule msg = do

503typeClassConstraintFor :: Declaration -> Maybe P.Constraint

504typeClassConstraintFor Declaration{..} =

505 case declInfo of

506− TypeClassDeclaration tyArgs _ ->

506+ TypeClassDeclaration tyArgs _ _ ->

507 Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing)

508 _ ->

509 Nothing

src/Language/PureScript/Docs/Convert/Single.hs+19−2

@@ -9,12 +9,14 @@ import Control.Arrow (first)

9import Control.Category ((>>>))

10import Control.Monad

11

12+import Data.Bifunctor (bimap)

12import Data.Either

13import Data.Either

13import Data.List (nub)

14import Data.List (nub)

14import Data.Maybe (mapMaybe)

15import Data.Maybe (mapMaybe)

15import Data.Monoid ((<>))

16import Data.Monoid ((<>))

16import Data.Text (Text)

17import Data.Text (Text)

17import qualified Data.Text as T

18import qualified Data.Text as T

19+import qualified Data.Vector as V

18

20

19import Language.PureScript.Docs.Types

21import Language.PureScript.Docs.Types

20import qualified Language.PureScript as P

22import qualified Language.PureScript as P

@@ -127,10 +129,10 @@ convertDeclaration (P.ExternDataDeclaration _ kind') title =

127 basicDeclaration title (ExternDataDeclaration kind')

129 basicDeclaration title (ExternDataDeclaration kind')

128convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

130convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

129 basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty)

131 basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty)

130−convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info

132+convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =

131 Just (Right (mkDeclaration title info) { declChildren = children })

133 Just (Right (mkDeclaration title info) { declChildren = children })

132 where

134 where

133− info = TypeClassDeclaration (map (first T.unpack) args) implies

135+ info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps')

134 children = map convertClassMember ds

136 children = map convertClassMember ds

135 convertClassMember (P.PositionedDeclaration _ _ d) =

137 convertClassMember (P.PositionedDeclaration _ _ d) =

136 convertClassMember d

138 convertClassMember d

@@ -138,6 +140,21 @@ convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO:

138 ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty)

140 ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty)

139 convertClassMember _ =

141 convertClassMember _ =

140 P.internalError "convertDeclaration: Invalid argument to convertClassMember."

142 P.internalError "convertDeclaration: Invalid argument to convertClassMember."

143+ fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps

144+ where

145+ argsVec = V.fromList (map fst args)

146+ getArg i =

147+ maybe

148+ (P.internalError $ unlines

149+ [ "convertDeclaration: Functional dependency index"

150+ , show i

151+ , "is bigger than arguments list"

152+ , show (map fst args)

153+ , "Functional dependencies are"

154+ , show fundeps

155+ ]

156+ ) id $ argsVec V.!? i

157+ toArgs from to = (map getArg from, map getArg to)

141convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

158convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

142 Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl))

159 Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl))

143 where

160 where

src/Language/PureScript/Docs/Render.hs+11−1

@@ -50,10 +50,11 @@ renderDeclarationWithOptions opts Declaration{..} =

50 , syntax "="

51 , renderType' ty

52 ]

53− TypeClassDeclaration args implies ->

53+ TypeClassDeclaration args implies fundeps ->

54 [ keywordClass ]

55 ++ maybeToList superclasses

56 ++ [renderType' (typeApp declTitle args)]

57+ ++ fundepsList

57 ++ [keywordWhere | any isTypeClassMember declChildren]

58 ++ [keywordWhere | any isTypeClassMember declChildren]

58

59

59 where

60 where

@@ -64,6 +65,15 @@ renderDeclarationWithOptions opts Declaration{..} =

64 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

65 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

65 <> syntax ")" <> sp <> syntax "<="

66 <> syntax ")" <> sp <> syntax "<="

66

67

68+ fundepsList =

69+ [syntax "|" | not (null fundeps)]

70+ ++ [mintersperse

71+ (syntax "," <> sp)

72+ [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]

73+ ]

74+ where

75+ idents = mintersperse sp . map ident

76+

67 AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->

77 AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->

68 [ keywordFixity associativity

78 [ keywordFixity associativity

69 , syntax $ show precedence

79 , syntax $ show precedence

src/Language/PureScript/Docs/Types.hs+11−5

@@ -122,10 +122,10 @@ data DeclarationInfo

122 | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type

123

124 -- |

125− -- A type class, with its type arguments and its superclasses. Instances and

125+ -- A type class, with its type arguments, its superclasses and functional

126− -- members are represented as child declarations.

126+ -- dependencies. Instances and members are represented as child declarations.

127 --

128− | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]

128+ | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])]

129

130 -- |

131 -- An operator alias declaration, with the member the alias is for and the

@@ -141,7 +141,7 @@ declInfoToString (ValueDeclaration _) = "value"

141declInfoToString (DataDeclaration _ _) = "data"

142declInfoToString (ExternDataDeclaration _) = "externData"

143declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

144−declInfoToString (TypeClassDeclaration _ _) = "typeClass"

144+declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"

145declInfoToString (AliasDeclaration _ _) = "alias"

146

147isTypeClass :: Declaration -> Bool

@@ -413,6 +413,7 @@ asDeclarationInfo = do

413 "typeClass" ->

414 TypeClassDeclaration <$> key "arguments" asTypeArguments

415 <*> key "superclasses" (eachInArray asConstraint)

416+ <*> keyOrDefault "fundeps" [] asFunDeps

416 "alias" ->

417 "alias" ->

417 AliasDeclaration <$> key "fixity" asFixity

418 AliasDeclaration <$> key "fixity" asFixity

418 <*> key "alias" asFixityAlias

419 <*> key "alias" asFixityAlias

@@ -430,6 +431,11 @@ asKind = fromAesonParser

430asType :: Parse e P.Type

431asType :: Parse e P.Type

431asType = fromAesonParser

432asType = fromAesonParser

432

433

434+asFunDeps :: Parse PackageError [([String], [String])]

435+asFunDeps = eachInArray asFunDep

436+ where

437+ asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString)

438+

433asDataDeclType :: Parse PackageError P.DataDeclType

439asDataDeclType :: Parse PackageError P.DataDeclType

434asDataDeclType =

440asDataDeclType =

435 withString $ \s -> case s of

441 withString $ \s -> case s of

@@ -556,7 +562,7 @@ instance A.ToJSON DeclarationInfo where

556 DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]

562 DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]

557 ExternDataDeclaration kind -> ["kind" .= kind]

563 ExternDataDeclaration kind -> ["kind" .= kind]

558 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

564 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

559− TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

565+ TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps]

560 AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]

566 AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]

561

567

562instance A.ToJSON ChildDeclarationInfo where

568instance A.ToJSON ChildDeclarationInfo where

src/Language/PureScript/Errors.hs+2−2

@@ -972,7 +972,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

972 ]

973 renderHint (ErrorInDataBindingGroup nms) detail =

974 paras [ detail

975− , line $ "in data binding group " ++ T.intercalate ", " (map runProperName nms)

975+ , line $ "in data binding group " <> T.intercalate ", " (map runProperName nms)

976 ]

977 renderHint (ErrorInTypeSynonym name) detail =

978 paras [ detail

@@ -988,7 +988,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

988 ]

989 renderHint (ErrorInTypeClassDeclaration name) detail =

990 paras [ detail

991− , line $ "in type class declaration for " ++ markCode (runProperName name)

991+ , line $ "in type class declaration for " <> markCode (runProperName name)

992 ]

993 renderHint (ErrorInForeignImport nm) detail =

994 paras [ detail

src/Language/PureScript/Linter.hs+3−3

@@ -48,7 +48,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

48 f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs)

49 f dec = f' S.empty dec

50

51− f' :: S.Set String -> Declaration -> MultipleErrors

51+ f' :: S.Set Text -> Declaration -> MultipleErrors

52 f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec)

53 f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec)

54 f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty)

@@ -76,10 +76,10 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

76 | otherwise = mempty

77 stepDo _ _ = mempty

78

79− checkTypeVarsInDecl :: S.Set String -> Declaration -> MultipleErrors

79+ checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors

80 checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d

81

82− checkTypeVars :: S.Set String -> Type -> MultipleErrors

82+ checkTypeVars :: S.Set Text -> Type -> MultipleErrors

83 checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty

84 where

85 step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors)

tests/TestDocs.hs+23

@@ -58,6 +58,9 @@ data Assertion

58 -- | Assert that a particular declaration has a particular type class

59 -- constraint.

60 | ShouldBeConstrained P.ModuleName String String

61+ -- | Assert that a particular typeclass declaration has a functional

62+ -- dependency list.

63+ | ShouldHaveFunDeps P.ModuleName String [([String],[String])]

61 -- | Assert that a particular value declaration exists, and its type

64 -- | Assert that a particular value declaration exists, and its type

62 -- satisfies the given predicate.

65 -- satisfies the given predicate.

63 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))

66 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))

@@ -83,6 +86,8 @@ data AssertionFailure

83 | ChildDocumented P.ModuleName String String

86 | ChildDocumented P.ModuleName String String

84 -- | A constraint was missing.

87 -- | A constraint was missing.

85 | ConstraintMissing P.ModuleName String String

88 | ConstraintMissing P.ModuleName String String

89+ -- | A functional dependency was missing.

90+ | FunDepMissing P.ModuleName String [([String], [String])]

86 -- | A declaration had the wrong "type" (ie, value, type, type class)

91 -- | A declaration had the wrong "type" (ie, value, type, type class)

87 -- Fields: declaration title, expected "type", actual "type".

92 -- Fields: declaration title, expected "type", actual "type".

88 | WrongDeclarationType P.ModuleName String String String

93 | WrongDeclarationType P.ModuleName String String String

@@ -143,6 +148,20 @@ runAssertion assertion Docs.Module{..} =

143 Fail (WrongDeclarationType mn decl "value"

148 Fail (WrongDeclarationType mn decl "value"

144 (Docs.declInfoToString declInfo))

149 (Docs.declInfoToString declInfo))

145

150

151+ ShouldHaveFunDeps mn decl fds ->

152+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

153+ Nothing ->

154+ Fail (NotDocumented mn decl)

155+ Just Docs.Declaration{..} ->

156+ case declInfo of

157+ Docs.TypeClassDeclaration _ _ fundeps ->

158+ if fundeps == fds

159+ then Pass

160+ else Fail (FunDepMissing mn decl fds)

161+ _ ->

162+ Fail (WrongDeclarationType mn decl "value"

163+ (Docs.declInfoToString declInfo))

164+

146 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

165 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

147 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

166 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

148 Nothing ->

167 Nothing ->

@@ -271,6 +290,10 @@ testCases =

271 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"

290 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"

272 ])

291 ])

273

292

293+ , ("TypeClassWithFunDeps",

294+ [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]

295+ ])

296+

274 , ("NewOperators",

297 , ("NewOperators",

275 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

298 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

276 ])

299 ])