8c324a0 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Print functional dependencies in psc-docs output, fix #2439 (#2450)

* print fundeps with psc-docs #2439 * adding a test for fundeps in psc-docs * Fixing errors due to change from String to Text

commit8c324a0c0548ae8db3cf215fbf9bfe137994b131 authorGil Mizrahi <soupiral@gmail.com> dateMon 28 Nov 2016, 22:49 (10 years ago) parent1eb46ba

9 files changed+76−15

compare with golang

unifiedsplit

examples/docs/src/TypeClassWithFunDeps.purs+5 psc-docs/Tags.hs+1−1 src/Language/PureScript/Docs/Convert/ReExports.hs+1−1 src/Language/PureScript/Docs/Convert/Single.hs+19−2 src/Language/PureScript/Docs/Render.hs+11−1 src/Language/PureScript/Docs/Types.hs+11−5 src/Language/PureScript/Errors.hs+2−2 src/Language/PureScript/Linter.hs+3−3 tests/TestDocs.hs+23

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

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

2+module TypeClassWithFunDeps where

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 @@

11module Tags where

3−import Control.Arrow (first)

3+import Control.Arrow (first)

44import qualified Data.Text as T

55import qualified Language.PureScript as P

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

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

503503typeClassConstraintFor :: Declaration -> Maybe P.Constraint

504504typeClassConstraintFor Declaration{..} =

505505 case declInfo of

506− TypeClassDeclaration tyArgs _ ->

506+ TypeClassDeclaration tyArgs _ _ ->

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

508508 _ ->

509509 Nothing

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

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

99import Control.Category ((>>>))

1010import Control.Monad

1111

12+import Data.Bifunctor (bimap)

1213import Data.Either

1314import Data.List (nub)

1415import Data.Maybe (mapMaybe)

1516import Data.Monoid ((<>))

1617import Data.Text (Text)

1718import qualified Data.Text as T

19+import qualified Data.Vector as V

1820

1921import Language.PureScript.Docs.Types

2022import qualified Language.PureScript as P

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

127129 basicDeclaration title (ExternDataDeclaration kind')

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

129131 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 =

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

132134 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')

134136 children = map convertClassMember ds

135137 convertClassMember (P.PositionedDeclaration _ _ d) =

136138 convertClassMember d

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

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

139141 convertClassMember _ =

140142 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)

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

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

143160 where

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

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

5050 , syntax "="

5151 , renderType' ty

5252 ]

53− TypeClassDeclaration args implies ->

53+ TypeClassDeclaration args implies fundeps ->

5454 [ keywordClass ]

5555 ++ maybeToList superclasses

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

57+ ++ fundepsList

5758 ++ [keywordWhere | any isTypeClassMember declChildren]

5859

5960 where

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

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

6566 <> syntax ")" <> sp <> syntax "<="

6667

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+

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

6878 [ keywordFixity associativity

6979 , syntax $ show precedence

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

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

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

123123

124124 -- |

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

126− -- members are represented as child declarations.

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

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

127127 --

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

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

129129

130130 -- |

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

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

141141declInfoToString (DataDeclaration _ _) = "data"

142142declInfoToString (ExternDataDeclaration _) = "externData"

143143declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

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

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

145145declInfoToString (AliasDeclaration _ _) = "alias"

146146

147147isTypeClass :: Declaration -> Bool

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

413413 "typeClass" ->

414414 TypeClassDeclaration <$> key "arguments" asTypeArguments

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

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

416417 "alias" ->

417418 AliasDeclaration <$> key "fixity" asFixity

418419 <*> key "alias" asFixityAlias

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

430431asType :: Parse e P.Type

431432asType = fromAesonParser

432433

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

435+asFunDeps = eachInArray asFunDep

436+ where

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

438+

433439asDataDeclType :: Parse PackageError P.DataDeclType

434440asDataDeclType =

435441 withString $ \s -> case s of

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

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

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

558564 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]

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

561567

562568instance A.ToJSON ChildDeclarationInfo where

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

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

972972 ]

973973 renderHint (ErrorInDataBindingGroup nms) detail =

974974 paras [ detail

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

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

976976 ]

977977 renderHint (ErrorInTypeSynonym name) detail =

978978 paras [ detail

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

988988 ]

989989 renderHint (ErrorInTypeClassDeclaration name) detail =

990990 paras [ detail

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

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

992992 ]

993993 renderHint (ErrorInForeignImport nm) detail =

994994 paras [ detail

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

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

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

4949 f dec = f' S.empty dec

5050

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

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

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

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

5454 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

7676 | otherwise = mempty

7777 stepDo _ _ = mempty

7878

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

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

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

8181

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

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

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

8484 where

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

tests/TestDocs.hs+23

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

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

5959 -- constraint.

6060 | 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])]

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

6265 -- satisfies the given predicate.

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

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

8386 | ChildDocumented P.ModuleName String String

8487 -- | A constraint was missing.

8588 | ConstraintMissing P.ModuleName String String

89+ -- | A functional dependency was missing.

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

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

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

8893 | WrongDeclarationType P.ModuleName String String String

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

143148 Fail (WrongDeclarationType mn decl "value"

144149 (Docs.declInfoToString declInfo))

145150

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+

146165 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

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

148167 Nothing ->

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

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

272291 ])

273292

293+ , ("TypeClassWithFunDeps",

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

295+ ])

296+

274297 , ("NewOperators",

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

276299 ])