August 2017 - openSUSE Commits - openSUSE Mailing Lists

commit ghc-haskell-tools-rewrite for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-rewrite for openSUSE:Factory checked in at 2017-08-31 20:56:09 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-rewrite (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-rewrite.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-rewrite" Thu Aug 31 20:56:09 2017 rev:2 rq:513376 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-rewrite/ghc-haskell-tools-rewrite.changes 2017-04-12 18:06:47.681889994 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-rewrite.new/ghc-haskell-tools-rewrite.changes 2017-08-31 20:56:10.933787661 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:37 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-rewrite-0.5.0.0.tar.gz New: ---- haskell-tools-rewrite-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-rewrite.spec ++++++ --- /var/tmp/diff_new_pack.TeA7qa/_old 2017-08-31 20:56:11.645687635 +0200 +++ /var/tmp/diff_new_pack.TeA7qa/_new 2017-08-31 20:56:11.645687635 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-rewrite %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Facilities for generating new parts of the Haskell-Tools AST License: BSD-3-Clause ++++++ haskell-tools-rewrite-0.5.0.0.tar.gz -> haskell-tools-rewrite-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/ElementTypes.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/ElementTypes.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/ElementTypes.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/ElementTypes.hs 2017-05-03 22:13:56.000000000 +0200 @@ -2,8 +2,8 @@ import Language.Haskell.Tools.AST -type AnnList node dom = AnnListG node dom SrcTemplateStage -type AnnMaybe node dom = AnnMaybeG node dom SrcTemplateStage +type AnnList node dom = AnnListG node dom SrcTemplateStage +type AnnMaybe node dom = AnnMaybeG node dom SrcTemplateStage -- * Modules @@ -26,13 +26,13 @@ -- | Marks how related names will be imported or exported with a given name type SubSpec dom = Ann USubSpec dom SrcTemplateStage --- | Pragmas that must be used after the module head +-- | Pragmas that must be used after the module head type ModulePragma dom = Ann UModulePragma dom SrcTemplateStage --- | Pragmas that must be used before defining the module +-- | Pragmas that must be used before defining the module type FilePragma dom = Ann UFilePragma dom SrcTemplateStage --- | An import declaration: @import Module.Name@ +-- | An import declaration: @import Module.Name@ type ImportDecl dom = Ann UImportDecl dom SrcTemplateStage -- | Restriction on the imported names @@ -67,7 +67,7 @@ -- | The list of declarations that can appear in a typeclass type ClassBody dom = Ann UClassBody dom SrcTemplateStage --- | Members of a class declaration +-- | Members of a class declaration type ClassElement dom = Ann UClassElement dom SrcTemplateStage -- The declared (possibly parameterized) type (@ A x :+: B y @). @@ -88,10 +88,10 @@ -- | Marker for a field wildcard. Only needed to attach semantic information in a type-safe way. type FieldWildcard dom = Ann UFieldWildcard dom SrcTemplateStage --- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas +-- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas type FunDeps dom = Ann UFunDeps dom SrcTemplateStage --- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ +-- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ type FunDep dom = Ann UFunDep dom SrcTemplateStage -- | A constructor declaration for a datatype @@ -112,7 +112,7 @@ -- | The specification of the class instance declaration type InstanceHead dom = Ann UInstanceHead dom SrcTemplateStage --- | Overlap pragmas. Can be applied to class declarations and class instance declarations. +-- | Overlap pragmas. Can be applied to class declarations and class instance declarations. type OverlapPragma dom = Ann UOverlapPragma dom SrcTemplateStage -- | Type equations as found in closed type families (@ T A = S @) @@ -124,7 +124,10 @@ -- | A rewrite rule (@ "map/map" forall f g xs. map f (map g xs) = map (f.g) xs @) type Rule dom = Ann URule dom SrcTemplateStage --- | Annotation allows you to connect an expression to any declaration. +-- | A variable for a rewrite rule. With or without type signature. +type RuleVar dom = Ann URuleVar dom SrcTemplateStage + +-- | Annotation allows you to connect an expression to any declaration. type AnnotationSubject dom = Ann UAnnotationSubject dom SrcTemplateStage -- | Formulas of minimal annotations declaring which functions should be defined. @@ -177,7 +180,7 @@ -- | Value binding for top-level and local bindings type ValueBind dom = Ann UValueBind dom SrcTemplateStage --- | Clause of function binding +-- | Clause of function binding type Match dom = Ann UMatch dom SrcTemplateStage -- | Something on the left side of the match @@ -186,7 +189,7 @@ -- | Right hand side of a value binding (possible with guards): (@ = 3 @ or @ | x == 1 = 3; | otherwise = 4 @) type Rhs dom = Ann URhs dom SrcTemplateStage --- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) +-- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) type GuardedRhs dom = Ann UGuardedRhs dom SrcTemplateStage -- | Guards for value bindings and pattern matches (@ Just v <- x, v > 1 @) @@ -195,7 +198,7 @@ -- | Bindings that are enabled in local blocks (where or let). type LocalBind dom = Ann ULocalBind dom SrcTemplateStage --- | Local bindings attached to a declaration (@ where x = 42 @) +-- | Local bindings attached to a declaration (@ where x = 42 @) type LocalBinds dom = Ann ULocalBinds dom SrcTemplateStage -- | A fixity signature (@ infixl 5 +, - @). @@ -241,7 +244,7 @@ -- | Right hand side of a match (possible with guards): (@ -> 3 @ or @ | x == 1 -> 3; | otherwise -> 4 @) type CaseRhs dom = Ann UCaseRhs dom SrcTemplateStage --- | A guarded right-hand side of pattern matches binding (@ | x > 3 -> 2 @) +-- | A guarded right-hand side of pattern matches binding (@ | x > 3 -> 2 @) type GuardedCaseRhs dom = Ann UGuardedCaseRhs dom SrcTemplateStage -- | Field update expressions @@ -289,13 +292,13 @@ -- * Template Haskell --- | A template haskell splice +-- | A template haskell splice type Splice dom = Ann USplice dom SrcTemplateStage -- | Template Haskell bracket expressions type Bracket dom = Ann UBracket dom SrcTemplateStage --- | Template haskell quasi-quotation: @[quoter|str]@ +-- | Template haskell quasi-quotation: @[quoter|str]@ type QuasiQuote dom = Ann UQuasiQuote dom SrcTemplateStage -- * Literals @@ -315,7 +318,7 @@ -- Linear implicit parameter: @%x@. Non-linear implicit parameter: @?x@. type QualifiedName dom = Ann UQualifiedName dom SrcTemplateStage --- | Parts of a qualified name. +-- | Parts of a qualified name. type NamePart dom = Ann UNamePart dom SrcTemplateStage -- | Program elements formatted as string literals (import packages, pragma texts) @@ -381,6 +384,7 @@ type AssertionList dom = AnnList UAssertion dom type CompStmtList dom = AnnList UCompStmt dom type RuleList dom = AnnList URule dom +type RuleVarList dom = AnnList URuleVar dom type RoleList dom = AnnList URole dom type MinimalFormulaList dom = AnnList UMinimalFormula dom type FunDepList dom = AnnList UFunDep dom diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs 2017-05-03 22:13:56.000000000 +0200 @@ -29,10 +29,10 @@ mkFunctionBind' :: Name dom -> [([Pattern dom], Expr dom)] -> ValueBind dom mkFunctionBind' name matches = mkFunctionBind $ map (\(args, rhs) -> mkMatch (mkMatchLhs name args) (mkUnguardedRhs rhs) Nothing) matches --- | Creates a clause of function binding +-- | Creates a clause of function binding mkMatch :: MatchLhs dom -> Rhs dom -> Maybe (LocalBinds dom) -> Match dom -mkMatch lhs rhs locs - = mkAnn (child <> child <> child) +mkMatch lhs rhs locs + = mkAnn (child <> child <> child) $ UMatch lhs rhs (mkAnnMaybe (after " " opt) locs) -- | Creates a match lhs with the function name and parameter names (@ f a b @) @@ -41,12 +41,11 @@ -- | Creates an infix match lhs for an operator (@ a + b @) mkInfixLhs :: Pattern dom -> Operator dom -> Pattern dom -> [Pattern dom] -> MatchLhs dom -mkInfixLhs lhs op rhs pats +mkInfixLhs lhs op rhs pats = mkAnn (child <> child <> child <> child) $ UInfixLhs lhs op rhs (mkAnnList (after " " $ separatedBy " " list) pats) -- | Local bindings attached to a declaration (@ where x = 42 @) mkLocalBinds :: [LocalBind dom] -> MaybeLocalBinds dom --- TODO: make the indentation automatic mkLocalBinds = mkAnnMaybe (relativeIndented 2 $ after "\nwhere " opt) . Just . mkAnn child . ULocalBinds . mkAnnList (indented list) @@ -71,17 +70,17 @@ -- | Creates a left-associative fixity declaration (@ infixl 5 +, - @). mkInfixL :: Int -> Operator dom -> FixitySignature dom -mkInfixL prec op = mkAnn (child <> " " <> child <> " " <> child) +mkInfixL prec op = mkAnn (child <> " " <> child <> " " <> child) $ UFixitySignature (mkAnn "infixl" AssocLeft) (mkAnnMaybe opt $ Just $ mkAnn (fromString (show prec)) (Precedence prec)) (mkAnnList (separatedBy ", " list) [op]) -- | Creates a right-associative fixity declaration (@ infixr 5 +, - @). mkInfixR :: Int -> Operator dom -> FixitySignature dom -mkInfixR prec op = mkAnn (child <> " " <> child <> " " <> child) +mkInfixR prec op = mkAnn (child <> " " <> child <> " " <> child) $ UFixitySignature (mkAnn "infixr" AssocRight) (mkAnnMaybe opt $ Just $ mkAnn (fromString (show prec)) (Precedence prec)) (mkAnnList (separatedBy ", " list) [op]) -- | Creates a non-associative fixity declaration (@ infix 5 +, - @). mkInfix :: Int -> Operator dom -> FixitySignature dom -mkInfix prec op = mkAnn (child <> " " <> child <> " " <> child) +mkInfix prec op = mkAnn (child <> " " <> child <> " " <> child) $ UFixitySignature (mkAnn "infix" AssocNone) (mkAnnMaybe opt $ Just $ mkAnn (fromString (show prec)) (Precedence prec)) (mkAnnList (separatedBy ", " list) [op]) -- | Creates an unguarded right-hand-side (@ = 3 @) @@ -92,7 +91,7 @@ mkGuardedRhss :: [GuardedRhs dom] -> Rhs dom mkGuardedRhss = mkAnn child . UGuardedRhss . mkAnnList (indented list) --- | Creates a guarded right-hand side of a value binding (@ | x > 3 = 2 @) +-- | Creates a guarded right-hand side of a value binding (@ | x > 3 = 2 @) mkGuardedRhs :: [RhsGuard dom] -> Expr dom -> GuardedRhs dom mkGuardedRhs guards expr = mkAnn ("| " <> child <> " = " <> child) $ UGuardedRhs (mkAnnList (separatedBy ", " list) guards) expr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs 2017-05-17 13:32:17.000000000 +0200 @@ -8,16 +8,16 @@ import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.ElementTypes -import Language.Haskell.Tools.AST.Gen.Utils (mkAnn, mkAnnList, mkAnnMaybe) +import Language.Haskell.Tools.AST.Gen.Utils import Language.Haskell.Tools.Transform -- | Creates a type synonym ( @type String = [Char]@ ) -mkTypeDecl :: DeclHead dom -> Type dom -> Decl dom +mkTypeDecl :: DeclHead dom -> Type dom -> Decl dom mkTypeDecl dh typ = mkAnn (child <> " :: " <> child) $ UTypeDecl dh typ -- | Creates a standalone deriving declaration (@ deriving instance X T @) mkStandaloneDeriving :: Maybe (OverlapPragma dom) -> InstanceRule dom -> Decl dom -mkStandaloneDeriving overlap instRule = mkAnn ("deriving instance" <> child <> child) +mkStandaloneDeriving overlap instRule = mkAnn ("deriving instance" <> child <> child) $ UDerivDecl (mkAnnMaybe (after " " opt) overlap) instRule -- | Creates a fixity declaration (@ infixl 5 +, - @) @@ -44,44 +44,45 @@ -- | Creates a data or newtype declaration. mkDataDecl :: DataOrNewtypeKeyword dom -> Maybe (Context dom) -> DeclHead dom -> [ConDecl dom] -> Maybe (Deriving dom) -> Decl dom -mkDataDecl keyw ctx dh cons derivs - = mkAnn (child <> " " <> child <> child <> child <> child) - $ UDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh +mkDataDecl keyw ctx dh cons derivs + = mkAnn (child <> " " <> child <> child <> child <> child) + $ UDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Creates a GADT-style data or newtype declaration. mkGADTDataDecl :: DataOrNewtypeKeyword dom -> Maybe (Context dom) -> DeclHead dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] -> Maybe (Deriving dom) -> Decl dom -mkGADTDataDecl keyw ctx dh kind cons derivs - = mkAnn (child <> " " <> child <> child <> child <> child <> child) - $ UGDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh - (mkAnnMaybe (after " " opt) kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkGADTDataDecl keyw ctx dh kind cons derivs + = mkAnn (child <> " " <> child <> child <> child <> child <> child) + $ UGDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh + (mkAnnMaybe (after " " opt) kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Creates a GADT constructor declaration (@ D1 :: Int -> T String @) mkGadtConDecl :: [Name dom] -> Type dom -> GadtConDecl dom -mkGadtConDecl names typ = mkAnn (child <> " :: " <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) - (mkAnn child $ UGadtNormalType typ) +mkGadtConDecl names typ + = mkAnn (child <> " :: " <> child <> child <> child) + $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) emptyList noth (mkAnn child $ UGadtNormalType typ) -- | Creates a GADT constructor declaration with record syntax (@ D1 :: { val :: Int } -> T String @) mkGadtRecordConDecl :: [Name dom] -> [FieldDecl dom] -> Type dom -> GadtConDecl dom -mkGadtRecordConDecl names flds typ - = mkAnn (child <> " :: " <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) - $ mkAnn (child <> " -> " <> child) +mkGadtRecordConDecl names flds typ + = mkAnn (child <> " :: " <> child <> child <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) emptyList noth + $ mkAnn (child <> " -> " <> child) $ UGadtRecordType (mkAnnList (after "{ " $ separatedBy ", " $ followedBy " }" list) flds) typ -- | Creates an ordinary data constructor (@ C t1 t2 @) mkConDecl :: Name dom -> [Type dom] -> ConDecl dom -mkConDecl name args = mkAnn (child <> child) $ UConDecl name (mkAnnList (after " " $ separatedBy " " $ list) args) +mkConDecl name args = mkAnn (child <> child <> child <> child) $ UConDecl emptyList noth name (mkAnnList (after " " $ separatedBy " " $ list) args) -- | Creates a record data constructor (@ Point { x :: Double, y :: Double } @) mkRecordConDecl :: Name dom -> [FieldDecl dom] -> ConDecl dom -mkRecordConDecl name fields - = mkAnn (child <> " { " <> child <> " }") $ URecordDecl name (mkAnnList (separatedBy ", " list) fields) +mkRecordConDecl name fields + = mkAnn (child <> child <> child <> " { " <> child <> " }") $ URecordDecl emptyList noth name (mkAnnList (separatedBy ", " list) fields) -- | Creates an infix data constructor (@ t1 :+: t2 @) mkInfixConDecl :: Type dom -> Operator dom -> Type dom -> ConDecl dom -mkInfixConDecl lhs op rhs = mkAnn (child <> " " <> child <> " " <> child) $ UInfixConDecl lhs op rhs +mkInfixConDecl lhs op rhs = mkAnn (child <> child <> child <> " " <> child <> " " <> child) $ UInfixConDecl emptyList noth lhs op rhs -- | Creates a field declaration (@ fld :: Int @) for a constructor mkFieldDecl :: [Name dom] -> Type dom -> FieldDecl dom @@ -104,11 +105,11 @@ -- | Creates a type class declaration (@ class X a where f = ... @) mkClassDecl :: Maybe (Context dom) -> DeclHead dom -> [FunDep dom] -> Maybe (ClassBody dom) -> Decl dom -mkClassDecl ctx dh funDeps body +mkClassDecl ctx dh funDeps body = let fdeps = case funDeps of [] -> Nothing _ -> Just $ mkAnn child $ UFunDeps $ mkAnnList (separatedBy ", " list) funDeps - in mkAnn ("class " <> child <> child <> child <> child) - $ UClassDecl (mkAnnMaybe (followedBy " " opt) ctx) dh (mkAnnMaybe (after " | " opt) fdeps) (mkAnnMaybe opt body) + in mkAnn ("class " <> child <> child <> child <> child) + $ UClassDecl (mkAnnMaybe (followedBy " " opt) ctx) dh (mkAnnMaybe (after " | " opt) fdeps) (mkAnnMaybe opt body) -- | Creates the list of declarations that can appear in a typeclass mkClassBody :: [ClassElement dom] -> ClassBody dom @@ -122,11 +123,11 @@ mkClassElemDef :: ValueBind dom -> ClassElement dom mkClassElemDef = mkAnn child . UClsDef --- | Creates an associated type synonym in class: @ type T y :: * @ +-- | Creates an associated type synonym in class: @ type T y :: * @ mkClassElemTypeFam :: DeclHead dom -> Maybe (TypeFamilySpec dom) -> ClassElement dom mkClassElemTypeFam dh tfSpec = mkAnn ("type " <> child) $ UClsTypeFam (mkAnn (child <> child) $ UTypeFamily dh (mkAnnMaybe opt tfSpec)) --- | Creates an associated data synonym in class: @ data T y :: * @ +-- | Creates an associated data synonym in class: @ data T y :: * @ mkClassElemDataFam :: DeclHead dom -> Maybe (KindConstraint dom) -> ClassElement dom mkClassElemDataFam dh kind = mkAnn ("data " <> child) $ UClsTypeFam (mkAnn (child <> child) $ UDataFamily dh (mkAnnMaybe opt kind)) @@ -140,7 +141,7 @@ -- | Creates a functional dependency, given on the form @l1 ... ln -> r1 ... rn@ mkFunDep :: [Name dom] -> [Name dom] -> FunDep dom -mkFunDep lhss rhss = mkAnn (child <> " -> " <> child) +mkFunDep lhss rhss = mkAnn (child <> " -> " <> child) $ UFunDep (mkAnnList (separatedBy ", " list) lhss) (mkAnnList (separatedBy ", " list) rhss) -- | Minimal pragma: @ {-\# MINIMAL (==) | (/=) \#-} @ in a class @@ -183,12 +184,12 @@ -- | Creates a type class instance declaration (@ instance X T [where f = ...] @) mkInstanceDecl :: Maybe (OverlapPragma dom) -> InstanceRule dom -> Maybe (InstBody dom) -> Decl dom -mkInstanceDecl overlap instRule body = mkAnn ("instance " <> child <> child <> child) +mkInstanceDecl overlap instRule body = mkAnn ("instance " <> child <> child <> child) $ UInstDecl (mkAnnMaybe (after " " opt) overlap) instRule (mkAnnMaybe opt body) -- | The instance declaration rule, which is, roughly, the part of the instance declaration before the where keyword. mkInstanceRule :: Maybe (Context dom) -> InstanceHead dom -> InstanceRule dom -mkInstanceRule ctx ih +mkInstanceRule ctx ih = mkAnn (child <> child <> child) $ UInstanceRule (mkAnnMaybe (after " " opt) Nothing) (mkAnnMaybe (after " " opt) ctx) ih -- | Type or class name as a part of the instance declaration @@ -196,7 +197,7 @@ mkInstanceHead = mkAnn child . UInstanceHeadCon -- | Infix application of the type/class name to the left operand as a part of the instance declaration -mkInfixInstanceHead :: Type dom -> Name dom -> InstanceHead dom +mkInfixInstanceHead :: Type dom -> Operator dom -> InstanceHead dom mkInfixInstanceHead typ n = mkAnn (child <> child) $ UInstanceHeadInfix typ n -- | Parenthesized instance head as a part of the instance declaration @@ -225,17 +226,17 @@ -- | An associated data type implementation (@ data A X = C1 | C2 @) int a type class instance mkInstanceDataFamilyDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> [ConDecl dom] -> Maybe (Deriving dom) -> InstBodyDecl dom -mkInstanceDataFamilyDef keyw instRule cons derivs - = mkAnn (child <> " " <> child <> child <> child) - $ UInstBodyDataDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkInstanceDataFamilyDef keyw instRule cons derivs + = mkAnn (child <> " " <> child <> child <> child) + $ UInstBodyDataDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | An associated data type implemented using GADT style int a type class instance -mkInstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] +mkInstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] -> Maybe (Deriving dom) -> InstBodyDecl dom -mkInstanceDataFamilyGADTDef keyw instRule kind cons derivs - = mkAnn (child <> " " <> child <> child <> child) - $ UInstBodyGadtDataDecl keyw instRule (mkAnnMaybe opt kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkInstanceDataFamilyGADTDef keyw instRule kind cons derivs + = mkAnn (child <> " " <> child <> child <> child) + $ UInstBodyGadtDataDecl keyw instRule (mkAnnMaybe opt kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Specialize instance pragma (no phase selection is allowed) in a type class instance @@ -243,39 +244,39 @@ mkInstanceSpecializePragma = mkAnn ("{-# SPECIALIZE " <> child <> " #-}") . USpecializeInstance -- | @OVERLAP@ pragma for type instance definitions -mkEnableOverlap :: OverlapPragma dom +mkEnableOverlap :: OverlapPragma dom mkEnableOverlap = mkAnn "{-# OVERLAP #-}" UEnableOverlap -- | @NO_OVERLAP@ pragma for type instance definitions -mkDisableOverlap :: OverlapPragma dom +mkDisableOverlap :: OverlapPragma dom mkDisableOverlap = mkAnn "{-# NO_OVERLAP #-}" UDisableOverlap -- | @OVERLAPPABLE@ pragma for type instance definitions -mkOverlappable :: OverlapPragma dom +mkOverlappable :: OverlapPragma dom mkOverlappable = mkAnn "{-# OVERLAPPABLE #-}" UOverlappable -- | @OVERLAPPING@ pragma for type instance definitions -mkOverlapping :: OverlapPragma dom +mkOverlapping :: OverlapPragma dom mkOverlapping = mkAnn "{-# OVERLAPPING #-}" UOverlapping -- | @OVERLAPS@ pragma for type instance definitions -mkOverlaps :: OverlapPragma dom +mkOverlaps :: OverlapPragma dom mkOverlaps = mkAnn "{-# OVERLAPS #-}" UOverlaps -- | @INCOHERENT@ pragma for type instance definitions -mkIncoherentOverlap :: OverlapPragma dom +mkIncoherentOverlap :: OverlapPragma dom mkIncoherentOverlap = mkAnn "{-# INCOHERENT #-}" UIncoherentOverlap -- * Type roles -- | Creates a role annotations (@ type role Ptr representational @) mkRoleDecl :: QualifiedName dom -> [Role dom] -> Decl dom -mkRoleDecl name roles +mkRoleDecl name roles = mkAnn ("type role " <> child <> child) $ URoleDecl name $ mkAnnList (separatedBy " " $ after " " list) roles -- | Marks a given type parameter as @nominal@. mkNominalRole :: Role dom -mkNominalRole = mkAnn "nominal" UNominal +mkNominalRole = mkAnn "nominal" UNominal -- | Marks a given type parameter as @representational@. mkRepresentationalRole :: Role dom @@ -289,7 +290,7 @@ -- | Creates a foreign import (@ foreign import foo :: Int -> IO Int @) mkForeignImport :: CallConv dom -> Maybe (Safety dom) -> Name dom -> Type dom -> Decl dom -mkForeignImport cc safety name typ = mkAnn (child <> child <> " " <> child <> " :: " <> child) +mkForeignImport cc safety name typ = mkAnn (child <> child <> " " <> child <> " :: " <> child) $ UForeignImport cc (mkAnnMaybe (after " " opt) safety) name typ -- | Creates a foreign export (@ foreign export ccall foo :: Int -> IO Int @) @@ -310,7 +311,7 @@ -- | Specifies that the given foreign import is @unsafe@. mkUnsafe :: Safety dom -mkUnsafe = mkAnn "unsafe" UUnsafe +mkUnsafe = mkAnn "unsafe" UUnsafe -- * Type and data families @@ -319,11 +320,11 @@ mkTypeFamily dh famSpec = mkAnn child $ UTypeFamilyDecl (mkAnn (child <> child) $ UTypeFamily dh (mkAnnMaybe (after " " opt) famSpec)) -- | Creates a closed type family declaration ( @type family F x where F Int = (); F a = Int@ ) -mkClosedTypeFamily :: DeclHead dom -> Maybe (KindConstraint dom) -> [TypeEqn dom] -> Decl dom -mkClosedTypeFamily dh kind typeqs = mkAnn (child <> child <> " where " <> child) +mkClosedTypeFamily :: DeclHead dom -> Maybe (TypeFamilySpec dom) -> [TypeEqn dom] -> Decl dom +mkClosedTypeFamily dh kind typeqs = mkAnn (child <> child <> " where " <> child) $ UClosedTypeFamilyDecl dh (mkAnnMaybe (after " " opt) kind) (mkAnnList (indented list) typeqs) --- | Creates a data family declaration (@ data family A a :: * -> * @) +-- | Creates a data family declaration (@ data family A a :: * -> * @) mkDataFamily :: DeclHead dom -> Maybe (KindConstraint dom) -> Decl dom mkDataFamily dh kind = mkAnn child $ UTypeFamilyDecl (mkAnn (child <> child) $ UDataFamily dh (mkAnnMaybe (after " " opt) kind)) @@ -332,8 +333,8 @@ mkTypeFamilyKindSpec = mkAnn child . UTypeFamilyKind -- | Specifies the injectivity of a type family (@ = r | r -> a @) -mkTypeFamilyInjectivitySpec :: Name dom -> [Name dom] -> TypeFamilySpec dom -mkTypeFamilyInjectivitySpec res dependent +mkTypeFamilyInjectivitySpec :: TyVar dom -> [Name dom] -> TypeFamilySpec dom +mkTypeFamilyInjectivitySpec res dependent = mkAnn child (UTypeFamilyInjectivity $ mkAnn (child <> " -> " <> child) $ UInjectivityAnn res (mkAnnList (separatedBy " " list) dependent)) -- | Type equations as found in closed type families (@ T A = S @) @@ -346,22 +347,22 @@ -- | Creates a data instance declaration (@ data instance Fam T = Con1 | Con2 @) mkDataInstance :: DataOrNewtypeKeyword dom -> InstanceRule dom -> [ConDecl dom] -> Maybe (Deriving dom) -> Decl dom -mkDataInstance keyw instRule cons derivs - = mkAnn (child <> " instance " <> child <> " = " <> child <> child) - $ UDataInstDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkDataInstance keyw instRule cons derivs + = mkAnn (child <> " instance " <> child <> " = " <> child <> child) + $ UDataInstDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Creates a GADT-style data instance declaration (@ data instance Fam T where ... @) mkGadtDataInstance :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] -> Decl dom -mkGadtDataInstance keyw instRule kind cons - = mkAnn (child <> " instance " <> child <> child <> " where " <> child) +mkGadtDataInstance keyw instRule kind cons + = mkAnn (child <> " instance " <> child <> child <> " where " <> child) $ UGDataInstDecl keyw instRule (mkAnnMaybe (after " " opt) kind) (mkAnnList (indented list) cons) -- * Pattern synonyms -- | Creates a pattern synonym (@ pattern Arrow t1 t2 = App \"->\" [t1, t2] @) mkPatternSynonym :: PatSynLhs dom -> PatSynRhs dom -> Decl dom -mkPatternSynonym lhs rhs = mkAnn child $ UPatternSynonymDecl $ mkAnn ("pattern " <> child <> " " <> child) +mkPatternSynonym lhs rhs = mkAnn child $ UPatternSynonymDecl $ mkAnn ("pattern " <> child <> " " <> child) $ UPatternSynonym lhs rhs -- | Creates a left hand side of a pattern synonym with a constructor name and arguments (@ Arrow t1 t2 @) @@ -374,7 +375,7 @@ -- | Creates a record-style pattern synonym left-hand side (@ Arrow { arrowFrom, arrowTo } @) mkRecordPatSyn :: Name dom -> [Name dom] -> PatSynLhs dom -mkRecordPatSyn con args +mkRecordPatSyn con args = mkAnn (child <> child) $ URecordPatSyn con $ mkAnnList (after "{ " $ separatedBy ", " $ followedBy " }" list) args -- | Creates an automatically two-way pattern synonym (@ = App \"Int\" [] @) @@ -385,9 +386,9 @@ mkOneWayPatSyn :: Pattern dom -> PatSynRhs dom mkOneWayPatSyn = mkAnn ("<- " <> child) . UOneDirectionalPatSyn --- | Creates a pattern synonym with the other direction explicitely specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) +-- | Creates a pattern synonym with the other direction explicitly specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) mkTwoWayPatSyn :: Pattern dom -> [Match dom] -> PatSynRhs dom -mkTwoWayPatSyn pat match = mkAnn ("<- " <> child <> child) $ UBidirectionalPatSyn pat $ mkAnnMaybe (after " where " opt) +mkTwoWayPatSyn pat match = mkAnn ("<- " <> child <> child) $ UBidirectionalPatSyn pat $ mkAnnMaybe (after " where " opt) $ Just $ mkAnn child $ UPatSynWhere $ mkAnnList (indented list) match -- | Creates a pattern type signature declaration (@ pattern Succ :: Int -> Int @) @@ -409,13 +410,15 @@ -- | A pragma that marks definitions as deprecated (@ {-\# DEPRECATED f "f will be replaced by g" \#-} @) mkDeprPragma :: [Name dom] -> String -> TopLevelPragma dom -mkDeprPragma defs msg = mkAnn ("{-# DEPRECATED " <> child <> " " <> child <> " #-}") - $ UDeprPragma (mkAnnList (separatedBy ", " list) defs) $ mkAnn ("\"" <> child <> "\"") $ UStringNode msg +mkDeprPragma defs msg = mkAnn ("{-# DEPRECATED " <> child <> " " <> child <> " #-}") + $ UDeprPragma (mkAnnList (separatedBy ", " list) defs) + (mkAnnList (separatedBy ", " list) [mkAnn ("\"" <> child <> "\"") $ UStringNode msg]) -- | A pragma that marks definitions as deprecated (@ {-\# WARNING unsafePerformIO "you should know what you are doing" \#-} @) mkWarningPragma :: [Name dom] -> String -> TopLevelPragma dom -mkWarningPragma defs msg = mkAnn ("{-# WARNING " <> child <> " " <> child <> " #-}") - $ UWarningPragma (mkAnnList (separatedBy ", " list) defs) $ mkAnn ("\"" <> child <> "\"") $ UStringNode msg +mkWarningPragma defs msg = mkAnn ("{-# WARNING " <> child <> " " <> child <> " #-}") + $ UWarningPragma (mkAnnList (separatedBy ", " list) defs) + (mkAnnList (separatedBy ", " list) [mkAnn ("\"" <> child <> "\"") $ UStringNode msg]) -- | A pragma that annotates a definition with an arbitrary value (@ {-\# ANN f 42 \#-} @) mkAnnPragma :: AnnotationSubject dom -> Expr dom -> TopLevelPragma dom @@ -423,7 +426,7 @@ -- | A pragma that marks a function for inlining to the compiler (@ {-\# INLINE thenUs \#-} @) mkInlinePragma :: Maybe (ConlikeAnnot dom) -> Maybe (PhaseControl dom) -> Name dom -> TopLevelPragma dom -mkInlinePragma conlike phase name +mkInlinePragma conlike phase name = mkAnn ("{-# INLINE " <> child <> child <> child <> " #-}") $ UInlinePragmaDecl $ mkAnn child $ UInlinePragma (mkAnnMaybe (followedBy " " opt) conlike) (mkAnnMaybe (followedBy " " opt) phase) name @@ -440,33 +443,37 @@ -- | A pragma for maintaining line numbers in generated sources (@ {-\# LINE 123 "somefile" \#-} @) mkLinePragma :: Int -> Maybe (StringNode dom) -> TopLevelPragma dom -mkLinePragma line filename - = mkAnn ("{-# LINE " <> child <> child <> " #-}") +mkLinePragma line filename + = mkAnn ("{-# LINE " <> child <> child <> " #-}") $ ULinePragma (mkAnn child $ LineNumber line) (mkAnnMaybe (after " " opt) filename) -- | A pragma that tells the compiler that a polymorph function should be optimized for a given type (@ {-\# SPECIALISE f :: Int -> b -> b \#-} @) mkSpecializePragma :: Maybe (PhaseControl dom) -> Name dom -> [Type dom] -> TopLevelPragma dom -mkSpecializePragma phase def specTypes - = mkAnn ("{-# SPECIALIZE " <> child <> child <> " " <> child <> " #-}") - $ USpecializePragma (mkAnnMaybe (after " " opt) phase) def $ mkAnnList (separatedBy ", " list) specTypes +mkSpecializePragma phase def specTypes + = mkAnn child (USpecializeDecl + $ mkAnn ("{-# SPECIALIZE " <> child <> child <> " " <> child <> " #-}") + $ USpecializePragma (mkAnnMaybe (after " " opt) phase) def $ mkAnnList (separatedBy ", " list) specTypes) -- | Marks that the pragma should be applied from a given compile phase (@ [2] @) mkPhaseControlFrom :: Integer -> PhaseControl dom -mkPhaseControlFrom phaseNum - = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt Nothing) (mkAnn child $ PhaseNumber phaseNum) +mkPhaseControlFrom phaseNum + = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt Nothing) (mkAnnMaybe opt $ Just $ mkAnn child $ PhaseNumber phaseNum) -- | Marks that the pragma should be applied until a given compile phase (@ [~2] @) mkPhaseControlUntil :: Integer -> PhaseControl dom -mkPhaseControlUntil phaseNum - = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt $ Just $ mkAnn "~" PhaseInvert) - (mkAnn child $ PhaseNumber phaseNum) +mkPhaseControlUntil phaseNum + = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt $ Just $ mkAnn "~" PhaseInvert) + (mkAnnMaybe opt $ Just $ mkAnn child $ PhaseNumber phaseNum) -- | A rewrite rule (@ "map/map" forall f g xs. map f (map g xs) = map (f.g) xs @) -mkRewriteRule :: String -> Maybe (PhaseControl dom) -> [TyVar dom] -> Expr dom -> Expr dom -> Rule dom +mkRewriteRule :: String -> Maybe (PhaseControl dom) -> [RuleVar dom] -> Expr dom -> Expr dom -> Rule dom mkRewriteRule name phase vars lhs rhs = mkAnn (child <> " " <> child <> child <> child <> " = " <> child) $ URule (mkAnn ("\"" <> child <> "\"") $ UStringNode name) (mkAnnMaybe (followedBy " " opt) phase) - (mkAnnList (after "forall " $ separatedBy " " $ followedBy ". " list) vars) lhs rhs + (mkAnnList (after "forall " $ separatedBy " " $ followedBy ". " list) (vars)) lhs rhs + +mkRuleVar :: Name dom -> RuleVar dom +mkRuleVar name = mkAnn child (URuleVar name) -- | The definition with the given name is annotated mkNameAnnotation :: Name dom -> AnnotationSubject dom diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Types.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Types.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Types.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Types.hs 2017-05-03 22:13:56.000000000 +0200 @@ -2,7 +2,7 @@ -- The bindings defined here create a the annotated version of the AST constructor with the same name. -- For example, @mkTyForall@ creates the annotated version of the @TyForall@ AST constructor. {-# LANGUAGE OverloadedStrings - , TypeFamilies + , TypeFamilies #-} module Language.Haskell.Tools.AST.Gen.Types where @@ -56,7 +56,7 @@ -- | Infix type constructor (@ (a <: b) @) mkInfixTypeApp :: Type dom -> Operator dom -> Type dom -> Type dom mkInfixTypeApp left op right = mkAnn (child <> " " <> child <> " " <> child) (UTyInfix left op right) - + -- | Type surrounded by parentheses (@ (T a) @) mkParenType :: Type dom -> Type dom mkParenType = mkAnn ("(" <> child <> ")") . UTyParen @@ -124,27 +124,23 @@ -- | A list of elements as a kind. mkPromotedListType :: [Type dom] -> Type dom -mkPromotedListType +mkPromotedListType = mkAnn child . UTyPromoted . mkAnn ("[" <> child <> "]") . UPromotedList . mkAnnList (separatedBy ", " list) -- | A tuple of elements as a kind. mkPromotedTupleType :: [Type dom] -> Type dom -mkPromotedTupleType +mkPromotedTupleType = mkAnn child . UTyPromoted . mkAnn ("(" <> child <> ")") . UPromotedTuple . mkAnnList (separatedBy ", " list) --- | Kind of the unit value @()@. +-- | Kind of the unit value @()@. mkPromotedUnitType :: Type dom mkPromotedUnitType = mkAnn child $ UTyPromoted $ mkAnn "()" UPromotedUnit -- * Generation of contexts --- | Creates a context of one assertion (@ C a => ... @) -mkContextOne :: Assertion dom -> Context dom -mkContextOne = mkAnn (child <> " =>") . UContextOne - --- | Creates a context of a set of assertions (@ (C1 a, C2 b) => ... @, but can be one: @ (C a) => ... @) -mkContextMulti :: [Assertion dom] -> Context dom -mkContextMulti = mkAnn ("(" <> child <> ") =>") . UContextMulti . mkAnnList (separatedBy ", " list) +-- | Creates a context of assertions (@ C a => ... @) +mkContext :: Assertion dom -> Context dom +mkContext = mkAnn (child <> " =>") . UContext -- * Generation of assertions @@ -161,3 +157,6 @@ mkImplicitAssert :: Name dom -> Type dom -> Assertion dom mkImplicitAssert n t = mkAnn (child <> " :: " <> child) $ UImplicitAssert n t +-- | Creates a list of assertions (@ (Eq a, Show a) @) +mkTupleAssertion :: [Assertion dom] -> Assertion dom +mkTupleAssertion ass = mkAnn ("(" <> child <> ")") $ UTupleAssert $ mkAnnList (separatedBy ", " list) ass diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Binds.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Binds.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Binds.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Binds.hs 2017-05-03 22:13:56.000000000 +0200 @@ -5,7 +5,7 @@ import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.ElementTypes --- | Non-function binding (@ v = "12" @) +-- | Non-function binding (@ v = "12" @) pattern SimpleBind :: Pattern dom -> Rhs dom -> MaybeLocalBinds dom -> ValueBind dom pattern SimpleBind p r l <- Ann _ (USimpleBind p r l) @@ -13,7 +13,7 @@ pattern FunctionBind :: MatchList dom -> ValueBind dom pattern FunctionBind matches <- Ann _ (UFunBind matches) --- | Clause of function binding +-- | Clause of function binding pattern Match :: MatchLhs dom -> Rhs dom -> MaybeLocalBinds dom -> Match dom pattern Match lhs rhs locs <- Ann _ (UMatch lhs rhs locs) @@ -45,8 +45,6 @@ pattern TypeSignature :: NameList dom -> Type dom -> TypeSignature dom pattern TypeSignature n t <- Ann _ (UTypeSignature n t) --- TODO: match precedence with maybe - -- | A left-associative fixity declaration (@ infixl 5 +, - @). pattern InfixL :: OperatorList dom -> FixitySignature dom pattern InfixL op <- Ann _ (UFixitySignature (Ann _ AssocLeft) _ op) @@ -67,7 +65,7 @@ pattern GuardedRhss :: GuardedRhsList dom -> Rhs dom pattern GuardedRhss rhss <- Ann _ (UGuardedRhss rhss) --- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) +-- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) pattern GuardedRhs :: RhsGuardList dom -> Expr dom -> GuardedRhs dom pattern GuardedRhs guards expr <- Ann _ (UGuardedRhs guards expr) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Decls.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Decls.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Decls.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Decls.hs 2017-05-17 13:32:17.000000000 +0200 @@ -10,7 +10,7 @@ -- * Declarations -- | A type synonym ( @type String = [Char]@ ) -pattern TypeDecl :: DeclHead dom -> Type dom -> Decl dom +pattern TypeDecl :: DeclHead dom -> Type dom -> Decl dom pattern TypeDecl dh typ <- Ann _ (UTypeDecl dh typ) -- | Standalone deriving declaration (@ deriving instance X T @) @@ -39,7 +39,7 @@ -- * Data type definitions --- | A data or newtype declaration. Empty data type declarations without +-- | A data or newtype declaration. Empty data type declarations without -- where keyword are always belong to DataDecl. pattern DataDecl :: DataOrNewtypeKeyword dom -> MaybeContext dom -> DeclHead dom -> ConDeclList dom -> MaybeDeriving dom -> Decl dom pattern DataDecl keyw ctx dh cons derivs <- Ann _ (UDataDecl keyw ctx dh cons derivs) @@ -50,23 +50,23 @@ -- | GADT constructor declaration (@ D1 :: Int -> T String @) pattern GadtConDecl :: NameList dom -> Type dom -> GadtConDecl dom -pattern GadtConDecl names typ <- Ann _ (UGadtConDecl names (Ann _ (UGadtNormalType typ))) +pattern GadtConDecl names typ <- Ann _ (UGadtConDecl names _ _ (Ann _ (UGadtNormalType typ))) -- | GADT constructor declaration with record syntax (@ D1 :: { val :: Int } -> T String @) pattern GadtRecordConDecl :: NameList dom -> FieldDeclList dom -> Type dom -> GadtConDecl dom -pattern GadtRecordConDecl names fields typ <- Ann _ (UGadtConDecl names (Ann _ (UGadtRecordType fields typ))) +pattern GadtRecordConDecl names fields typ <- Ann _ (UGadtConDecl names _ _ (Ann _ (UGadtRecordType fields typ))) -- | Ordinary data constructor (@ C t1 t2 @) pattern ConDecl :: Name dom -> TypeList dom -> ConDecl dom -pattern ConDecl name args <- Ann _ (UConDecl name args) +pattern ConDecl name args <- Ann _ (UConDecl _ _ name args) -- | Creates a record data constructor (@ Point { x :: Double, y :: Double } @) pattern RecordConDecl :: Name dom -> FieldDeclList dom -> ConDecl dom -pattern RecordConDecl name fields <- Ann _ (URecordDecl name fields) +pattern RecordConDecl name fields <- Ann _ (URecordDecl _ _ name fields) -- | Infix data constructor (@ t1 :+: t2 @) pattern InfixConDecl :: Type dom -> Operator dom -> Type dom -> ConDecl dom -pattern InfixConDecl lhs op rhs <- Ann _ (UInfixConDecl lhs op rhs) +pattern InfixConDecl lhs op rhs <- Ann _ (UInfixConDecl _ _ lhs op rhs) -- | Field declaration (@ fld :: Int @) pattern FieldDecl :: NameList dom -> Type dom -> FieldDecl dom @@ -86,11 +86,11 @@ pattern NewtypeKeyword :: DataOrNewtypeKeyword dom pattern NewtypeKeyword <- Ann _ UNewtypeKeyword --- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas +-- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas pattern FunDeps :: FunDepList dom -> FunDeps dom pattern FunDeps fds <- Ann _ (UFunDeps fds) --- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ +-- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ pattern FunDep :: NameList dom -> NameList dom -> FunDep dom pattern FunDep lhs rhs <- Ann _ (UFunDep lhs rhs) @@ -191,7 +191,7 @@ pattern InstanceDataFamilyDef keyw instRule cons derivs <- Ann _ (UInstBodyDataDecl keyw instRule cons derivs ) -- | An associated data definition as a GADT (@ data A X where B :: Int -> A X @) in a class instance -pattern InstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> MaybeKindConstraint dome -> AnnListG UGadtConDecl dom stage +pattern InstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> MaybeKindConstraint dome -> AnnListG UGadtConDecl dom stage -> MaybeDeriving dom -> InstBodyDecl dom pattern InstanceDataFamilyGADTDef keyw instRule kind cons derivs <- Ann _ (UInstBodyGadtDataDecl keyw instRule kind cons derivs) @@ -208,40 +208,40 @@ pattern InstanceHead name <- Ann _ (UInstanceHeadCon name) -- | Infix application of the type/class name to the left operand as an instance head -pattern InfixInstanceHead :: Type dom -> Name dom -> InstanceHead dom +pattern InfixInstanceHead :: Type dom -> Operator dom -> InstanceHead dom pattern InfixInstanceHead typ n <- Ann _ (UInstanceHeadInfix typ n) -- | Parenthesized instance head pattern ParenInstanceHead :: InstanceHead dom -> InstanceHead dom pattern ParenInstanceHead ih <- Ann _ (UInstanceHeadParen ih) --- | Type application as an instance head +-- | Type application as an instance head pattern AppInstanceHead :: InstanceHead dom -> Type dom -> InstanceHead dom pattern AppInstanceHead fun arg <- Ann _ (UInstanceHeadApp fun arg) -- | @OVERLAP@ pragma -pattern EnableOverlap :: OverlapPragma dom -pattern EnableOverlap <- Ann _ UEnableOverlap +pattern EnableOverlap :: OverlapPragma dom +pattern EnableOverlap <- Ann _ UEnableOverlap -- | @NO_OVERLAP@ pragma -pattern DisableOverlap :: OverlapPragma dom -pattern DisableOverlap <- Ann _ UDisableOverlap +pattern DisableOverlap :: OverlapPragma dom +pattern DisableOverlap <- Ann _ UDisableOverlap -- | @OVERLAPPABLE@ pragma -pattern Overlappable :: OverlapPragma dom -pattern Overlappable <- Ann _ UOverlappable +pattern Overlappable :: OverlapPragma dom +pattern Overlappable <- Ann _ UOverlappable -- | @OVERLAPPING@ pragma -pattern Overlapping :: OverlapPragma dom -pattern Overlapping <- Ann _ UOverlapping +pattern Overlapping :: OverlapPragma dom +pattern Overlapping <- Ann _ UOverlapping -- | @OVERLAPS@ pragma -pattern Overlaps :: OverlapPragma dom -pattern Overlaps <- Ann _ UOverlaps +pattern Overlaps :: OverlapPragma dom +pattern Overlaps <- Ann _ UOverlaps -- | @INCOHERENT@ pragma -pattern IncoherentOverlap :: OverlapPragma dom -pattern IncoherentOverlap <- Ann _ UIncoherentOverlap +pattern IncoherentOverlap :: OverlapPragma dom +pattern IncoherentOverlap <- Ann _ UIncoherentOverlap -- * Type roles @@ -282,7 +282,7 @@ -- | Specifies that the given foreign import is @unsafe@. pattern Unsafe :: Safety dom -pattern Unsafe <- Ann _ UUnsafe +pattern Unsafe <- Ann _ UUnsafe -- * Pattern synonyms @@ -310,7 +310,7 @@ pattern OneWayPatSyn :: Pattern dom -> PatSynRhs dom pattern OneWayPatSyn pat <- Ann _ (UOneDirectionalPatSyn pat) --- | A pattern synonym with the other direction explicitely specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) +-- | A pattern synonym with the other direction explicitly specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) pattern TwoWayPatSyn :: Pattern dom -> MatchList dom -> PatSynRhs dom pattern TwoWayPatSyn pat match <- Ann _ (UBidirectionalPatSyn pat (AnnJust (Ann _ (UPatSynWhere match)))) @@ -344,7 +344,7 @@ pattern GadtDataInstance keyw instRule kind cons <- Ann _ (UGDataInstDecl keyw instRule kind cons ) -- | A closed type family declaration -pattern ClosedTypeFamily :: DeclHead dom -> MaybeKindConstraint dom -> TypeEqnList dom -> Decl dom +pattern ClosedTypeFamily :: DeclHead dom -> MaybeTypeFamilySpec dom -> TypeEqnList dom -> Decl dom pattern ClosedTypeFamily dh kind typeqs <- Ann _ (UClosedTypeFamilyDecl dh kind typeqs) -- | Specifies the kind of a type family (@ :: * -> * @) @@ -352,7 +352,7 @@ pattern TypeFamilyKindSpec kind <- Ann _ (UTypeFamilyKind kind) -- | Specifies the injectivity of a type family (@ = r | r -> a @) -pattern TypeFamilyInjectivitySpec :: Name dom -> NameList dom -> TypeFamilySpec dom +pattern TypeFamilyInjectivitySpec :: TyVar dom -> NameList dom -> TypeFamilySpec dom pattern TypeFamilyInjectivitySpec res dependent <- Ann _ (UTypeFamilyInjectivity (Ann _ (UInjectivityAnn res dependent))) -- | Type equations as found in closed type families (@ T A = S @) @@ -371,11 +371,11 @@ -- | A pragma that marks definitions as deprecated (@ {-\# DEPRECATED f "f will be replaced by g" \#-} @) pattern DeprPragma :: NameList dom -> String -> TopLevelPragma dom -pattern DeprPragma defs msg <- Ann _ (UDeprPragma defs (Ann _ (UStringNode msg))) +pattern DeprPragma defs msg <- Ann _ (UDeprPragma defs (AnnList [Ann _ (UStringNode msg)])) -- | A pragma that marks definitions as deprecated (@ {-\# WARNING unsafePerformIO "you should know what you are doing" \#-} @) pattern WarningPragma :: NameList dom -> String -> TopLevelPragma dom -pattern WarningPragma defs msg <- Ann _ (UWarningPragma defs (Ann _ (UStringNode msg))) +pattern WarningPragma defs msg <- Ann _ (UWarningPragma defs (AnnList [Ann _ (UStringNode msg)])) -- | A pragma that annotates a definition with an arbitrary value (@ {-\# ANN f 42 \#-} @) pattern AnnPragma :: AnnotationSubject dom -> Expr dom -> TopLevelPragma dom @@ -399,18 +399,18 @@ -- | A pragma that tells the compiler that a polymorph function should be optimized for a given type (@ {-\# SPECIALISE f :: Int -> b -> b \#-} @) pattern SpecializePragma :: MaybePhaseControl dom -> Name dom -> TypeList dom -> TopLevelPragma dom -pattern SpecializePragma phase def specTypes <- Ann _ (USpecializePragma phase def specTypes) +pattern SpecializePragma phase def specTypes <- Ann _ (USpecializeDecl (Ann _ (USpecializePragma phase def specTypes))) -- | Marks that the pragma should be applied from a given compile phase (@ [2] @) pattern PhaseControlFrom :: Integer -> PhaseControl dom -pattern PhaseControlFrom phaseNum <- Ann _ (UPhaseControl AnnNothing (Ann _ (PhaseNumber phaseNum))) +pattern PhaseControlFrom phaseNum <- Ann _ (UPhaseControl AnnNothing (AnnJust (Ann _ (PhaseNumber phaseNum)))) -- | Marks that the pragma should be applied until a given compile phase (@ [~2] @) pattern PhaseControlUntil :: Integer -> PhaseControl dom -pattern PhaseControlUntil phaseNum <- Ann _ (UPhaseControl (AnnJust _) (Ann _ (PhaseNumber phaseNum))) +pattern PhaseControlUntil phaseNum <- Ann _ (UPhaseControl (AnnJust _) (AnnJust (Ann _ (PhaseNumber phaseNum)))) -- | A rewrite rule (@ "map/map" forall f g xs. map f (map g xs) = map (f.g) xs @) -pattern RewriteRule :: String -> MaybePhaseControl dom -> TyVarList dom -> Expr dom -> Expr dom -> Rule dom +pattern RewriteRule :: String -> MaybePhaseControl dom -> RuleVarList dom -> Expr dom -> Expr dom -> Rule dom pattern RewriteRule name phase vars lhs rhs <- Ann _ (URule (Ann _ (UStringNode name)) phase vars lhs rhs) -- | The definition with the given name is annotated @@ -427,4 +427,4 @@ -- | A @CONLIKE@ modifier for an @INLINE@ pragma. pattern ConlikeAnnotation :: ConlikeAnnot dom -pattern ConlikeAnnotation <- Ann _ UConlikeAnnot \ No newline at end of file +pattern ConlikeAnnotation <- Ann _ UConlikeAnnot diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Types.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Types.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Types.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Types.hs 2017-05-03 22:13:56.000000000 +0200 @@ -108,7 +108,7 @@ pattern PromotedTupleType :: TypeList dom -> Type dom pattern PromotedTupleType elems <- Ann _ (UTyPromoted (Ann _ (UPromotedTuple elems))) --- | Kind of the unit value @()@. +-- | Kind of the unit value @()@. pattern PromotedUnitType :: Type dom pattern PromotedUnitType <- Ann _ (UTyPromoted (Ann _ UPromotedUnit)) @@ -124,13 +124,9 @@ -- * Contexts --- | One assertion (@ C a => ... @) -pattern ContextOne :: Assertion dom -> Context dom -pattern ContextOne n <- Ann _ (UContextOne n) - --- | A set of assertions (@ (C1 a, C2 b) => ... @, but can be one: @ (C a) => ... @) -pattern ContextMulti :: AssertionList dom -> Context dom -pattern ContextMulti n <- Ann _ (UContextMulti n) +-- | A context of assertions (@ C a => ... @) +pattern Context :: Assertion dom -> Context dom +pattern Context n <- Ann _ (UContext n) -- * Assertions @@ -145,3 +141,7 @@ -- | Assertion for implicit parameter binding (@ ?cmp :: a -> a -> Bool @) pattern ImplicitAssert :: Name dom -> Type dom -> Assertion dom pattern ImplicitAssert n t <- Ann _ (UImplicitAssert n t) + +-- | A list of assertions (@ (Eq a, Show a) @) +pattern TupleAssert :: [Assertion dom] -> Assertion dom +pattern TupleAssert ass <- Ann _ (UTupleAssert (AnnList ass)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/haskell-tools-rewrite.cabal new/haskell-tools-rewrite-0.8.0.0/haskell-tools-rewrite.cabal --- old/haskell-tools-rewrite-0.5.0.0/haskell-tools-rewrite.cabal 2017-01-31 20:55:16.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/haskell-tools-rewrite.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-rewrite -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Facilities for generating new parts of the Haskell-Tools AST description: Contains utility functions to generate parts of the Haskell-Tools AST. Generates these elements to be compatible with the source annotations that are already present on the AST. The package is divided into modules based on which language elements can the given module generate. This packages should be used during the transformations to generate parts of the new AST. homepage: https://github.com/haskell-tools/haskell-tools @@ -12,7 +12,6 @@ cabal-version: >=1.10 library - ghc-options: -O2 exposed-modules: Language.Haskell.Tools.AST.Rewrite , Language.Haskell.Tools.AST.ElementTypes , Language.Haskell.Tools.AST.Gen @@ -45,21 +44,21 @@ , containers >= 0.5 && < 0.6 , references >= 0.3 && < 0.4 , ghc >= 8.0 && < 8.1 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 default-language: Haskell2010 test-suite haskell-tools-rewrite-tests type: exitcode-stdio-1.0 ghc-options: -with-rtsopts=-M2g hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: base >= 4.9 && < 4.10 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-rewrite >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-rewrite >= 0.8 && < 0.9 + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/test/Main.hs new/haskell-tools-rewrite-0.8.0.0/test/Main.hs --- old/haskell-tools-rewrite-0.5.0.0/test/Main.hs 2017-01-31 20:34:13.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/test/Main.hs 2017-05-03 22:13:56.000000000 +0200 @@ -11,11 +11,11 @@ main = defaultMain genTests genTests :: TestTree -genTests = testGroup "ast generation tests" +genTests = testGroup "ast generation tests" [ testGroup "name tests" testBase , testGroup "expression tests" (map makeGenTest testExprs) , testGroup "pattern tests" (map makeGenTest testPatterns) - , testGroup "type tests" (map makeGenTest testType) + , testGroup "type tests" (map makeGenTest testType) , testGroup "binding tests" (map makeGenTest testBinds) , testGroup "declaration tests" (map makeGenTest testDecls) , testGroup "module tests" (map makeGenTest testModules) @@ -31,26 +31,26 @@ , makeGenTest ("operator name", "(+)", mkParenName $ mkSimpleName "+") ] -testExprs - = [ ("infix", "a + 3", mkInfixApp (mkVar (mkName "a")) (mkUnqualOp "+") (mkLit $ mkIntLit 3)) +testExprs + = [ ("infix", "a + 3", mkInfixApp (mkVar (mkName "a")) (mkUnqualOp "+") (mkLit $ mkIntLit 3)) , ("section", "(\"xx\" ++)", mkLeftSection (mkLit (mkStringLit "xx")) (mkUnqualOp "++")) , ("tuple", "(1, [2, 3])", mkTuple [ mkLit (mkIntLit 1), mkList [ mkLit (mkIntLit 2), mkLit (mkIntLit 3) ] ]) , ("record constructor", "P { x = 1 }", mkRecCon (mkName "P") [ mkFieldUpdate (mkName "x") (mkLit $ mkIntLit 1) ]) , ("if", "if f a then x else y" , mkIf (mkApp (mkVar $ mkName "f") (mkVar $ mkName "a")) (mkVar $ mkName "x") (mkVar $ mkName "y")) , ("let", "let nat = [0..] in !z" - , mkLet [mkLocalValBind $ mkSimpleBind' (mkName "nat") (mkEnum (mkLit (mkIntLit 0)) Nothing Nothing)] + , mkLet [mkLocalValBind $ mkSimpleBind' (mkName "nat") (mkEnum (mkLit (mkIntLit 0)) Nothing Nothing)] (mkPrefixApp (mkUnqualOp "!") (mkVar $ mkName "z")) ) , ("case", "case x of Just y -> y\n" ++ " Nothing -> 0" - , mkCase (mkVar (mkName "x")) + , mkCase (mkVar (mkName "x")) [ mkAlt (mkAppPat (mkName "Just") [mkVarPat (mkName "y")]) (mkCaseRhs $ mkVar (mkName "y")) Nothing , mkAlt (mkVarPat $ mkName "Nothing") (mkCaseRhs $ mkLit $ mkIntLit 0) Nothing ]) , ("multiway if", "if | x > y -> x\n" ++ " | otherwise -> y" - , mkMultiIf [ mkGuardedCaseRhs - [ mkGuardCheck $ mkInfixApp (mkVar (mkName "x")) (mkUnqualOp ">") (mkVar (mkName "y"))] + , mkMultiIf [ mkGuardedCaseRhs + [ mkGuardCheck $ mkInfixApp (mkVar (mkName "x")) (mkUnqualOp ">") (mkVar (mkName "y"))] (mkVar (mkName "x")) , mkGuardedCaseRhs [mkGuardCheck $ mkVar (mkName "otherwise")] (mkVar (mkName "y")) ]) @@ -64,7 +64,7 @@ testPatterns = [ ("irrefutable pattern", "~[0, a]", mkIrrefutablePat $ mkListPat [ mkLitPat (mkIntLit 0), mkVarPat (mkName "a") ]) , ("named pattern", "p@Point{ x = 1 }" - , mkAsPat (mkName "p") $ mkRecPat (mkName "Point") + , mkAsPat (mkName "p") $ mkRecPat (mkName "Point") [ mkPatternField (mkName "x") (mkLitPat (mkIntLit 1)) ]) , ("bang pattern", "!(_, f -> 3)" , mkBangPat $ mkTuplePat [mkWildPat, mkViewPat (mkVar $ mkName "f") (mkLitPat (mkIntLit 3))]) @@ -72,8 +72,8 @@ testType = [ ("forall type", "forall x . Eq x => x -> ()" - , mkForallType [mkTypeVar (mkName "x")] - $ mkCtxType (mkContextOne (mkClassAssert (mkName "Eq") [mkVarType (mkName "x")])) + , mkForallType [mkTypeVar (mkName "x")] + $ mkCtxType (mkContext (mkClassAssert (mkName "Eq") [mkVarType (mkName "x")])) $ mkFunctionType (mkVarType (mkName "x")) (mkVarType (mkName "()"))) , ("type operators", "(A :+: B) (x, x)" , mkTypeApp (mkParenType $ mkInfixTypeApp (mkVarType (mkName "A")) (mkUnqualOp ":+:") (mkVarType (mkName "B"))) @@ -100,23 +100,23 @@ , ("binding", "id x = x" , mkValueBinding $ mkFunctionBind' (mkName "id") [([mkVarPat $ mkName "x"], mkVar $ mkName "x")]) , ("datatype definition", "data A a = A a deriving Show" - , mkDataDecl mkDataKeyword Nothing (mkDeclHeadApp (mkNameDeclHead (mkName "A")) (mkTypeVar (mkName "a"))) + , mkDataDecl mkDataKeyword Nothing (mkDeclHeadApp (mkNameDeclHead (mkName "A")) (mkTypeVar (mkName "a"))) [mkConDecl (mkName "A") [mkVarType (mkName "a")]] (Just $ mkDeriving [mkInstanceHead (mkName "Show")])) , ("record definition", "data A = A { x :: Int }" - , mkDataDecl mkDataKeyword Nothing (mkNameDeclHead (mkName "A")) + , mkDataDecl mkDataKeyword Nothing (mkNameDeclHead (mkName "A")) [mkRecordConDecl (mkName "A") [mkFieldDecl [mkName "x"] (mkVarType (mkName "Int"))]] Nothing) , ("typeclass definition", "class A t => C t where f :: t\n" ++ " type T t :: *" - , mkClassDecl (Just $ mkContextOne (mkClassAssert (mkName "A") [mkVarType (mkName "t")])) + , mkClassDecl (Just $ mkContext (mkClassAssert (mkName "A") [mkVarType (mkName "t")])) (mkDeclHeadApp (mkNameDeclHead (mkName "C")) (mkTypeVar (mkName "t"))) [] (Just $ mkClassBody [ mkClassElemSig $ mkTypeSignature (mkName "f") (mkVarType (mkName "t")) - , mkClassElemTypeFam (mkDeclHeadApp (mkNameDeclHead (mkName "T")) - (mkTypeVar (mkName "t"))) + , mkClassElemTypeFam (mkDeclHeadApp (mkNameDeclHead (mkName "T")) + (mkTypeVar (mkName "t"))) (Just $ mkTypeFamilyKindSpec $ mkKindConstraint $ mkKindStar) ]) ) , ( "instance definition", "instance C Int where f = 0" - , mkInstanceDecl Nothing (mkInstanceRule Nothing $ mkAppInstanceHead (mkInstanceHead $ mkName "C") (mkVarType (mkName "Int"))) + , mkInstanceDecl Nothing (mkInstanceRule Nothing $ mkAppInstanceHead (mkInstanceHead $ mkName "C") (mkVarType (mkName "Int"))) (Just $ mkInstanceBody [mkInstanceBind $ mkSimpleBind' (mkName "f") (mkLit $ mkIntLit 0)])) , ("fixity definition", "infixl 6 +", mkFixityDecl $ mkInfixL 6 (mkUnqualOp "+")) ] @@ -124,7 +124,7 @@ testModules = [ ("empty module", "", G.mkModule [] Nothing [] []) , ("exports", "module Test(x, A(a), B(..)) where" - , G.mkModule [] (Just $ mkModuleHead (G.mkModuleName "Test") Nothing + , G.mkModule [] (Just $ mkModuleHead (G.mkModuleName "Test") Nothing (Just $ mkExportSpecs [ mkExportSpec $ mkIESpec (mkName "x") Nothing , mkExportSpec $ mkIESpec (mkName "A") (Just $ mkSubList [mkName "a"]) @@ -133,11 +133,11 @@ , ("imports", "\nimport qualified A\n" ++ "import B as BB(x)\n" ++ "import B hiding (x)" - , G.mkModule [] Nothing + , G.mkModule [] Nothing [ mkImportDecl False True False Nothing (G.mkModuleName "A") Nothing Nothing - , mkImportDecl False False False Nothing (G.mkModuleName "B") (Just $ G.mkModuleName "BB") + , mkImportDecl False False False Nothing (G.mkModuleName "B") (Just $ G.mkModuleName "BB") (Just $ mkImportSpecList [mkIESpec (mkName "x") Nothing]) - , mkImportDecl False False False Nothing (G.mkModuleName "B") Nothing + , mkImportDecl False False False Nothing (G.mkModuleName "B") Nothing (Just $ mkImportHidingList [mkIESpec (mkName "x") Nothing]) ] []) ]

1 0

commit ghc-haskell-tools-refactor for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-refactor for openSUSE:Factory checked in at 2017-08-31 20:56:07 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-refactor (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-refactor.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-refactor" Thu Aug 31 20:56:07 2017 rev:2 rq:513375 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-refactor/ghc-haskell-tools-refactor.changes 2017-04-12 18:06:46.993987260 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-refactor.new/ghc-haskell-tools-refactor.changes 2017-08-31 20:56:09.106044464 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:05 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-refactor-0.5.0.0.tar.gz New: ---- haskell-tools-refactor-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-refactor.spec ++++++ --- /var/tmp/diff_new_pack.TjmYid/_old 2017-08-31 20:56:09.877936011 +0200 +++ /var/tmp/diff_new_pack.TjmYid/_new 2017-08-31 20:56:09.885934887 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-refactor %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Refactoring Tool for Haskell License: BSD-3-Clause ++++++ haskell-tools-refactor-0.5.0.0.tar.gz -> haskell-tools-refactor-0.8.0.0.tar.gz ++++++ ++++ 4614 lines of diff (skipped)

1 0

commit ghc-haskell-tools-prettyprint for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-prettyprint for openSUSE:Factory checked in at 2017-08-31 20:56:06 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-prettyprint (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-prettyprint.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-prettyprint" Thu Aug 31 20:56:06 2017 rev:2 rq:513374 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-prettyprint/ghc-haskell-tools-prettyprint.changes 2017-04-12 18:06:46.450064168 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-prettyprint.new/ghc-haskell-tools-prettyprint.changes 2017-08-31 20:56:07.286300144 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:13 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-prettyprint-0.5.0.0.tar.gz New: ---- haskell-tools-prettyprint-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-prettyprint.spec ++++++ --- /var/tmp/diff_new_pack.UgMxUS/_old 2017-08-31 20:56:08.066190567 +0200 +++ /var/tmp/diff_new_pack.UgMxUS/_new 2017-08-31 20:56:08.070190006 +0200 @@ -18,7 +18,7 @@ %global pkg_name haskell-tools-prettyprint Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Pretty printing of Haskell-Tools AST License: BSD-3-Clause @@ -33,6 +33,7 @@ BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-split-devel +BuildRequires: ghc-text-devel BuildRequires: ghc-uniplate-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ haskell-tools-prettyprint-0.5.0.0.tar.gz -> haskell-tools-prettyprint-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/PrettyPrint.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/PrettyPrint.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/PrettyPrint.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/PrettyPrint.hs 2017-05-17 18:59:17.000000000 +0200 @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleInstances , FlexibleContexts , UndecidableInstances - , NamedFieldPuns + , NamedFieldPuns #-} -- | Pretty printing the AST -module Language.Haskell.Tools.PrettyPrint (prettyPrint) where +module Language.Haskell.Tools.PrettyPrint (prettyPrint, toRoseTree) where import FastString (fsLit) import SrcLoc @@ -15,16 +15,18 @@ import Language.Haskell.Tools.Transform.SourceTemplate import Control.Monad.State +import Control.Reference import Data.Foldable (Foldable(..), concat) import Data.List as List import Data.List.Split (splitOn) import Data.Sequence hiding (null, replicate) +import Debug.Trace -- | Pretty prints an AST by using source templates stored as node info prettyPrint :: (SourceInfoTraversal node) => node dom SrcTemplateStage -> String prettyPrint = toList . printRose . toRoseTree -printRose :: RoseTree SrcTemplateStage -> Seq Char +printRose :: RoseTree SrcTemplateStage -> Seq Char printRose rt = evalState (printRose' startLoc rt) startLoc where startLoc = mkRealSrcLoc (fsLit "") 1 1 @@ -34,10 +36,11 @@ printRose' :: RealSrcLoc -> RoseTree SrcTemplateStage -> PPState (Seq Char) -- simple implementation could be optimized a bit -- warning: the length of the file should not exceed maxbound::Int -printRose' parent (RoseTree (RoseSpan (SourceTemplateNode rng elems minInd relInd)) children) +printRose' parent (RoseTree (RoseSpan (SourceTemplateNode rng elems minInd relInd)) children) = do slide <- calculateSlide rng let printTemplateElems :: [SourceTemplateElem] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) - printTemplateElems (TextElem txt : rest) children = putString slide min txt >+< printTemplateElems rest children + printTemplateElems (TextElem txtElems _ : rest) children = putString slide min txt >+< printTemplateElems rest children + where txt = concatMap (^. sourceTemplateText) txtElems printTemplateElems (ChildElem : rest) (child : children) = printRose' parent child >+< printTemplateElems rest children printTemplateElems [] [] = return empty printTemplateElems _ [] = error $ "More child elem in template than actual children (elems: " ++ show elems ++ ", children: " ++ show children ++ ")" @@ -46,81 +49,87 @@ min = minInd `max` getPosByRelative parent relInd printTemplateElems elems children - + printRose' _ (RoseTree (RoseList (SourceTemplateList {})) []) = return empty -printRose' parent (RoseTree (RoseList (SourceTemplateList rng bef aft defSep indented seps minInd relInd)) children) +printRose' parent (RoseTree (RoseList (SourceTemplateList rng bef aft defSep indented seps minInd relInd)) children) = do slide <- calculateSlide rng actRng <- get let min = minInd `max` getPosByRelative parent relInd - putString slide min bef - >+< (if indented then printListWithSepsIndented else printListWithSeps) actRng slide min actualSeps children + putString slide min bef + >+< (maybe printListWithSeps printListWithSepsIndented indented) actRng slide min actualSeps children >+< putString slide min aft - where actualSeps = case seps of [] -> repeat defSep - _ -> seps ++ repeat (last seps) + where stringSeps :: [String] + stringSeps = map (concatMap (^. sourceTemplateText)) (map fst seps) + actualSeps = case stringSeps of [] -> repeat defSep + _ -> stringSeps ++ repeat (last stringSeps) printRose' _ (RoseTree (RoseOptional (SourceTemplateOpt {})) []) = return empty -printRose' parent (RoseTree (RoseOptional (SourceTemplateOpt rng bef aft minInd relInd)) [child]) +printRose' parent (RoseTree (RoseOptional (SourceTemplateOpt rng bef aft minInd relInd)) [child]) = do slide <- calculateSlide rng actRng <- get let min = minInd `max` getPosByRelative parent relInd putString slide min bef >+< printRose' actRng child >+< putString slide min aft printRose' _ (RoseTree (RoseOptional _) _) = error "More than one child element in an optional node." - + getPosByRelative :: RealSrcLoc -> Maybe Int -> Int getPosByRelative sp (Just i) = srcLocCol sp + i - 1 getPosByRelative _ _ = 0 calculateSlide :: SrcSpan -> PPState Int -calculateSlide (RealSrcSpan originalSpan) = do +calculateSlide (RealSrcSpan originalSpan) = do actualSpan <- get return $ srcLocCol actualSpan - srcLocCol (realSrcSpanStart originalSpan) calculateSlide _ = return 0 putString :: Int -> Int -> String -> PPState (Seq Char) -putString slide minInd s +putString slide minInd s = do modify $ advanceStr newStr return (fromList newStr) where start:rest = splitOn "\n" s newStr = concat $ intersperse ("\n" ++ replicate slide ' ') (start : map (extendToNSpaces minInd) rest) extendToNSpaces n str = replicate n ' ' ++ (List.dropWhile (== ' ') $ List.take n str) ++ List.drop n str - + advanceStr :: String -> RealSrcLoc -> RealSrcLoc advanceStr s loc = foldl advanceSrcLoc loc s untilReaches :: String -> RealSrcLoc -> RealSrcLoc -> (String, Int) -untilReaches s start end - = let ls = splitOn "\n" s - in case ls of _:_:_ -> (unlines (init ls) ++) - `mapFst` untilReaches' (last ls) (advanceSrcLoc start '\n') end - _ -> (s, srcLocCol start) +untilReaches s start end + = let ls = splitOn "\n" s + in case ls of _:_:_ -> (unlines (init ls) ++) + `mapFst` untilReaches' (last ls) (advanceSrcLoc start '\n') end + _ -> (s, srcLocCol $ foldl advanceSrcLoc start s) where untilReaches' [] curr _ = ([], srcLocCol curr) untilReaches' (c:rest) curr until | srcLocCol advancedLoc <= srcLocCol until = (c:) `mapFst` untilReaches' rest advancedLoc until where advancedLoc = advanceSrcLoc curr c untilReaches' _ curr _ = ([], srcLocCol curr) - + mapFst :: (a -> b) -> (a, x) -> (b, x) mapFst f (a, x) = (f a, x) (>+<) :: PPState (Seq Char) -> PPState (Seq Char) -> PPState (Seq Char) (>+<) = liftM2 (><) - + printListWithSeps :: RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSeps = printListWithSeps' putString +printListWithSeps = printListWithSeps' (const putString) 0 -- | Prints the elements of a list where the elements must be printed in the same line (do stmts, case alts, let binds, ...) -printListWithSepsIndented :: RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSepsIndented parent slide minInd seps children +printListWithSepsIndented :: [Bool] -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) +printListWithSepsIndented indentedChildren parent slide minInd seps children = do base <- get - let putCorrectSep _ min s = do curr <- get - let (shortened, currCol) = untilReaches s curr base - putString 0 min $ shortened ++ replicate (srcLocCol base - currCol) ' ' - printListWithSeps' putCorrectSep parent slide minInd seps children - -printListWithSeps' :: (Int -> Int -> String -> PPState (Seq Char)) -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSeps' _ _ _ _ _ [] = return empty -printListWithSeps' _ parent _ _ _ [child] = printRose' parent child -printListWithSeps' putCorrectSep parent slide minInd (sep:seps) (child:children) - = printRose' parent child >+< putCorrectSep slide minInd sep >+< printListWithSeps' putCorrectSep parent slide minInd seps children -printListWithSeps' _ _ _ _ [] _ = error "printListWithSeps': the number of elements and separators does not match" + let putCorrectSep i _ min s | isIndented i + = do curr <- get + let (shortened, currCol) = untilReaches s curr base + putString 0 min $ shortened ++ replicate (srcLocCol base - currCol) ' ' + putCorrectSep _ slide minInd s = putString slide minInd s + printListWithSeps' putCorrectSep 0 parent slide minInd seps children + where -- the ith separator is before the ith element + isIndented i = case List.drop i indentedChildren of False:_ -> False; _ -> True + +printListWithSeps' :: (Int -> Int -> Int -> String -> PPState (Seq Char)) -> Int -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) +printListWithSeps' _ _ _ _ _ _ [] = return empty +printListWithSeps' _ _ parent _ _ _ [child] = printRose' parent child +printListWithSeps' putCorrectSep i parent slide minInd (sep:seps) (child:children) + = printRose' parent child >+< putCorrectSep i slide minInd sep >+< printListWithSeps' putCorrectSep (i+1) parent slide minInd seps children +printListWithSeps' _ _ _ _ _ [] _ = error "printListWithSeps': the number of elements and separators does not match" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs 2017-06-05 18:15:07.000000000 +0200 @@ -1,68 +1,78 @@ {-# LANGUAGE ScopedTypeVariables - , FlexibleContexts - , LambdaCase + , FlexibleContexts + , LambdaCase #-} -- | This transformation expands nodes to contain the comments that should be attached to them. After this, a -- normalizing transformation should be performed that expands parents to contain their children. module Language.Haskell.Tools.Transform.PlaceComments where +import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Reference hiding (element) import Data.Char (isSpace, isAlphaNum) import qualified Data.Map as Map +import Data.Map (Map) import Data.Maybe -import qualified Data.Set as Set (lookupLE, lookupGE, fromList) +import qualified Data.Set as Set +import Data.Set (Set) -import ApiAnnotation (AnnotationComment(..)) +import ApiAnnotation (ApiAnnKey, AnnotationComment(..)) import SrcLoc import Language.Haskell.Tools.AST -getNormalComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map SrcSpan [Located AnnotationComment] +getNormalComments :: Map SrcSpan [Located AnnotationComment] -> Map.Map SrcSpan [Located AnnotationComment] getNormalComments = Map.map (filter (not . isPragma . unLoc)) -getPragmaComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map String [Located String] -getPragmaComments comms = Map.fromListWith (++) $ map (\(L l (AnnBlockComment str)) -> (getPragmaCommand str, [L l str])) - $ filter (isPragma . unLoc) $ concatMap snd $ Map.toList comms +getPragmaComments :: Map SrcSpan [Located AnnotationComment] -> Map.Map String [Located String] +getPragmaComments comms = Map.fromListWith (++) $ map (\(L l (AnnBlockComment str)) -> (getPragmaCommand str, [L l str])) + $ filter (isPragma . unLoc) $ concatMap snd $ Map.toList comms where getPragmaCommand = takeWhile (\c -> isAlphaNum c || c == '_') . dropWhile isSpace . drop 3 isPragma :: AnnotationComment -> Bool isPragma (AnnBlockComment str) = take 3 str == "{-#" && take 3 (reverse str) == "}-#" isPragma _ = False --- | Puts comments in the nodes they should be attached to. Leaves the AST in a state where parent nodes --- does not contain all of their children. -placeComments :: RangeInfo stage => Map.Map SrcSpan [Located AnnotationComment] - -> Ann UModule dom stage - -> Ann UModule dom stage -placeComments comms mod - = resizeAnnots (concatMap (map nextSrcLoc . snd) (Map.toList comms)) mod +-- | Puts comments in the nodes they should be attached to. Watches for lexical tokens +-- that may divide the comment and the supposed element. +-- Leaves the AST in a state where parent nodes does not contain all of their children. +placeComments :: RangeInfo stage => Map ApiAnnKey [SrcSpan] -> Map.Map SrcSpan [Located AnnotationComment] + -> Ann UModule dom stage -> Ann UModule dom stage +placeComments tokens comms mod + = resizeAnnots (Set.filter (\rng -> srcSpanStart rng /= srcSpanEnd rng) $ Set.fromList $ concat (Map.elems tokens)) + (concatMap (map nextSrcLoc . snd) (Map.toList cleanedComments)) mod where spans = allElemSpans mod sortedElemStarts = Set.fromList $ map srcSpanStart spans sortedElemEnds = Set.fromList $ map srcSpanEnd spans - nextSrcLoc comm@(L sp _) + nextSrcLoc comm@(L sp _) = let after = fromMaybe noSrcLoc (Set.lookupLE (srcSpanStart sp) sortedElemEnds) before = fromMaybe noSrcLoc (Set.lookupGE (srcSpanEnd sp) sortedElemStarts) in ((after,before),comm) - + cleanedComments = Map.map (map cleanComment) comms + cleanComment (L loc (AnnLineComment txt)) + | last txt `elem` "\n\r" = L (mkSrcSpan (srcSpanStart loc) (decreaseCol (srcSpanEnd loc))) (AnnLineComment (init txt)) + cleanComment c = c + decreaseCol (RealSrcLoc l) = mkSrcLoc (srcLocFile l) (srcLocLine l) (srcLocCol l - 1) + decreaseCol l = l + allElemSpans :: (SourceInfoTraversal node, RangeInfo stage) => Ann node dom stage -> [SrcSpan] allElemSpans = execWriter . sourceInfoTraverse (SourceInfoTrf (\ni -> tell [ni ^. nodeSpan] >> pure ni) pure pure) - -resizeAnnots :: RangeInfo stage => [((SrcLoc, SrcLoc), Located AnnotationComment)] + +resizeAnnots :: RangeInfo stage => Set SrcSpan -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -> Ann UModule dom stage -> Ann UModule dom stage -resizeAnnots comments elem - = flip evalState comments $ - -- if a comment that could be attached to more than one documentable element (possibly nested) +resizeAnnots tokens comments elem + = flip evalState comments $ flip runReaderT tokens $ + -- if a comment that could be attached to more than one documentable element (possibly nested) -- the order of different documentable elements here decide which will be chosen - + modImports&annList !~ expandAnnot -- expand imports to cover their comments >=> modDecl&annList !~ expandTopLevelDecl -- expand declarations to cover their comments >=> expandAnnot -- expand the module itself to cover its comments $ elem -type ExpandType elem dom stage = Ann elem dom stage -> State [((SrcLoc, SrcLoc), Located AnnotationComment)] (Ann elem dom stage) +type ExpandType elem dom stage = Ann elem dom stage -> ReaderT (Set SrcSpan) (State [((SrcLoc, SrcLoc), Located AnnotationComment)]) (Ann elem dom stage) expandTopLevelDecl :: RangeInfo stage => ExpandType UDecl dom stage expandTopLevelDecl @@ -84,14 +94,14 @@ expandValueBind :: RangeInfo stage => ExpandType UValueBind dom stage expandValueBind - = valBindLocals & annJust & localBinds & annList !~ expandLocalBind + = valBindLocals & annJust & localBinds & annList !~ expandLocalBind >=> funBindMatches & annList & matchBinds & annJust & localBinds & annList !~ expandLocalBind >=> expandAnnot expandLocalBind :: RangeInfo stage => ExpandType ULocalBind dom stage expandLocalBind - = localVal !~ expandValueBind - >=> localSig !~ expandTypeSig + = localVal !~ expandValueBind + >=> localSig !~ expandTypeSig >=> expandAnnot expandConDecl :: RangeInfo stage => ExpandType UConDecl dom stage @@ -106,48 +116,56 @@ expandAnnot :: forall elem dom stage . RangeInfo stage => ExpandType elem dom stage expandAnnot elem = do let Just sp = elem ^? annotation&sourceInfo&nodeSpan - applicable <- gets (applicableComments (srcSpanStart sp) (srcSpanEnd sp)) - + tokens <- ask + applicable <- lift $ gets (applicableComments tokens (srcSpanStart sp) (srcSpanEnd sp)) + -- this check is just for performance (quick return if no modification is needed) if not (null applicable) then do -- the new span is the original plus all the covered spans - let newSp@(RealSrcSpan newSpan) + let newSp@(RealSrcSpan newSpan) = foldl combineSrcSpans (fromJust $ elem ^? nodeSp) (map (getLoc . snd) applicable) -- take out all comments that are now covered - modify (filter (not . (\case RealSrcSpan s -> newSpan `containsSpan` s; _ -> True) . getLoc . snd)) + lift $ modify (filter (not . (\case RealSrcSpan s -> newSpan `containsSpan` s; _ -> True) . getLoc . snd)) return $ nodeSp .= newSp $ elem else return elem where nodeSp :: Simple Partial (Ann elem dom stage) SrcSpan nodeSp = annotation&sourceInfo&nodeSpan - --- This classification does not prefer inline comments to previous line comments, this is implicitely done + +-- This classification does not prefer inline comments to previous line comments, this is implicitly done -- by the order in which the elements are traversed. -applicableComments :: SrcLoc -> SrcLoc - -> [((SrcLoc, SrcLoc), Located AnnotationComment)] +applicableComments :: Set SrcSpan -> SrcLoc -> SrcLoc + -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -applicableComments start end = filter applicableComment +applicableComments tokens start end = filter applicableComment where -- A comment that starts with | binds to the next documented element - applicableComment ((_, before), L _ comm) - | isCommentOnNext comm = before == start + applicableComment ((_, before), L sp comm) + | isCommentOnNext comm = before == start && noTokenBetween (srcSpanEnd sp) start -- A comment that starts with ^ binds to the previous documented element - applicableComment ((after, _), L _ comm) - | isCommentOnPrev comm = after == end + applicableComment ((after, _), L sp comm) + | isCommentOnPrev comm = after == end && noTokenBetween end (srcSpanStart sp) -- All other comment binds to the previous definition if it is on the same line - applicableComment ((after, _), L (RealSrcSpan loc) _) + applicableComment ((after, _), L sp@(RealSrcSpan loc) _) | after == end && srcLocLine (realSrcSpanStart loc) == getLineLocDefault end = True + && noTokenBetween end (srcSpanStart sp) -- or the next one if that is on the next line and the columns line up - applicableComment ((_, before), L (RealSrcSpan loc) _) + applicableComment ((_, before), L sp@(RealSrcSpan loc) _) | before == start && srcLocLine (realSrcSpanEnd loc) + 1 == getLineLocDefault start && srcLocCol (realSrcSpanStart loc) == getLineColDefault start + && noTokenBetween (srcSpanEnd sp) start = True applicableComment _ = False - + getLineLocDefault (RealSrcLoc l) = srcLocLine l getLineLocDefault _ = -1 getLineColDefault (RealSrcLoc l) = srcLocCol l getLineColDefault _ = -1 + noTokenBetween start end + = case Set.lookupGE (srcLocSpan start) tokens of + Just tok -> srcSpanStart tok >= end + Nothing -> True + -- * GHC mistakenly parses -- ^ and -- | comments as simple line comments. -- These functions check if a given comment is attached to the previous or next comment. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs 2017-05-03 22:13:56.000000000 +0200 @@ -15,14 +15,14 @@ instance SourceInfo RngTemplateStage where data SpanInfo RngTemplateStage = RangeTemplateNode { _rngTemplateNodeRange :: RealSrcSpan - , _rngTemplateNodeElems :: [RangeTemplateElem] + , _rngTemplateNodeElems :: [RangeTemplateElem] } deriving Data data ListInfo RngTemplateStage = RangeTemplateList { _rngTemplateListRange :: RealSrcSpan , _rngTmpListBefore :: String -- ^ Text that should be put before the first element if the list becomes populated , _rngTmpListAfter :: String -- ^ Text that should be put after the last element if the list becomes populated , _rngTmpDefaultSeparator :: String -- ^ The default separator if the list were empty - , _rngTmpIndented :: Bool -- ^ True, if the elements need to be aligned in the same column + , _rngTmpIndented :: Maybe [Bool] -- ^ False for elements that should be not aligned , _rngTmpSeparators :: [RealSrcSpan] -- ^ The actual separators that were found in the source code } deriving Data @@ -51,7 +51,7 @@ rngTmpDefaultSeparator :: Simple Lens (ListInfo RngTemplateStage) String rngTmpDefaultSeparator = lens _rngTmpDefaultSeparator (\v s -> s { _rngTmpDefaultSeparator = v }) -rngTmpIndented :: Simple Lens (ListInfo RngTemplateStage) Bool +rngTmpIndented :: Simple Lens (ListInfo RngTemplateStage) (Maybe [Bool]) rngTmpIndented = lens _rngTmpIndented (\v s -> s { _rngTmpIndented = v }) rngTmpSeparators :: Simple Lens (ListInfo RngTemplateStage) [RealSrcSpan] @@ -75,19 +75,19 @@ getRangeElemSpan (RangeElem sp) = Just sp getRangeElemSpan _ = Nothing -instance HasRange (SpanInfo RngTemplateStage) where +instance HasRange (SpanInfo RngTemplateStage) where getRange = RealSrcSpan . (^. rngTemplateNodeRange) setRange (RealSrcSpan sp) = rngTemplateNodeRange .= sp setRange _ = id -instance HasRange (ListInfo RngTemplateStage) where - getRange = RealSrcSpan . (^. rngTemplateListRange) - setRange (RealSrcSpan sp) = rngTemplateListRange .= sp +instance HasRange (ListInfo RngTemplateStage) where + getRange = RealSrcSpan . (^. rngTemplateListRange) + setRange (RealSrcSpan sp) = rngTemplateListRange .= sp setRange _ = id -instance HasRange (OptionalInfo RngTemplateStage) where +instance HasRange (OptionalInfo RngTemplateStage) where getRange = RealSrcSpan . (^. rngTemplateOptRange) - setRange (RealSrcSpan sp) = rngTemplateOptRange .= sp + setRange (RealSrcSpan sp) = rngTemplateOptRange .= sp setRange _ = id instance Show (SpanInfo RngTemplateStage) where @@ -96,7 +96,7 @@ show RangeTemplateList{..} = "<*" ++ shortShowSpan (RealSrcSpan _rngTemplateListRange) ++ " " ++ show _rngTmpListBefore ++ " " ++ show _rngTmpDefaultSeparator ++ " " ++ show _rngTmpListAfter ++ "*>" instance Show (OptionalInfo RngTemplateStage) where show RangeTemplateOpt{..} = "<?" ++ shortShowSpan (RealSrcSpan _rngTemplateOptRange) ++ " " ++ show _rngTmpOptBefore ++ " " ++ show _rngTmpOptAfter ++ "?>" - + instance Show RangeTemplateElem where show (RangeElem sp) = shortShowSpan (RealSrcSpan sp) show RangeChildElem = "<.>" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs 2017-05-24 19:51:13.000000000 +0200 @@ -1,65 +1,107 @@ -{-# LANGUAGE LambdaCase +{-# LANGUAGE LambdaCase , FlexibleContexts #-} --- | This module converts range templates into source templates. +-- | This module converts range templates into source templates. -- Basically it reads the source file and attaches parts of the source file to the AST elements that have the range of the given source code fragment. module Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate where +import Control.Monad.Identity import Control.Monad.State -import Control.Reference ((^.)) -import Data.Map +import Control.Reference +import Data.Map as Map +import Data.Ord (Ord(..), Ordering(..)) +import Data.Set as Set +import Data.List +import Data.List.Split +import FastString (mkFastString) import Language.Haskell.Tools.AST import Language.Haskell.Tools.Transform.RangeTemplate import Language.Haskell.Tools.Transform.SourceTemplate import SrcLoc import StringBuffer (StringBuffer, nextChar, atEnd) +import Debug.Trace rangeToSource :: SourceInfoTraversal node => StringBuffer -> Ann node dom RngTemplateStage -> Ann node dom SrcTemplateStage rangeToSource srcInput tree = let locIndices = getLocIndices tree srcMap = mapLocIndices srcInput locIndices - in applyFragments (elems srcMap) tree + in applyFragments (Map.elems srcMap) tree -- maps could be strict -- | Assigns an index (in the order they are used) for each range -getLocIndices :: SourceInfoTraversal e => Ann e dom RngTemplateStage -> Map OrdSrcSpan Int -getLocIndices = snd . flip execState (0, empty) . - sourceInfoTraverseDown (SourceInfoTrf +getLocIndices :: SourceInfoTraversal e => Ann e dom RngTemplateStage -> Set (RealSrcLoc, Int) +getLocIndices = snd . flip execState (0, Set.empty) . + sourceInfoTraverseDown (SourceInfoTrf (\ni -> do { mapM_ (\el -> case getRangeElemSpan el of Just sp -> modify (insertElem sp); _ -> return ()) (ni ^. rngTemplateNodeElems); return ni }) (\ni -> do { mapM_ (modify . insertElem) (ni ^. rngTmpSeparators); return ni }) - pure ) + pure ) (return ()) (return ()) - where insertElem sp (i,m) = (i+1, insert (OrdSrcSpan sp) i m) - - + where insertElem sp (i,m) = (i+1, Set.insert (realSrcSpanEnd sp, i) m) + -- | Partitions the source file in the order where the parts are used in the AST -mapLocIndices :: Ord k => StringBuffer -> Map OrdSrcSpan k -> Map k String -mapLocIndices inp = fst . foldlWithKey (\(new, str) sp k -> let (rem, val) = takeSpan str sp - in (insert k (reverse val) new, rem)) (empty, inp) - where takeSpan :: StringBuffer -> OrdSrcSpan -> (StringBuffer, String) - takeSpan str (OrdSrcSpan sp) = takeSpan' (realSrcSpanStart sp) (realSrcSpanEnd sp) (str,"") - takeSpan _ (NoOrdSrcSpan {}) = error "takeSpan: missing source span" - - takeSpan' :: RealSrcLoc -> RealSrcLoc -> (StringBuffer, String) -> (StringBuffer, String) - takeSpan' start end (sb, taken) | start < end && not (atEnd sb) - = let (c,rem) = nextChar sb in takeSpan' (advanceSrcLoc start c) end (rem, c:taken) - takeSpan' _ _ (rem, taken) = (rem, taken) - +mapLocIndices :: Ord k => StringBuffer -> Set (RealSrcLoc, k) -> Map k String +mapLocIndices inp = (^. _1) . Set.foldl (\(new, str, pos) (sp, k) -> let (rem, val, newPos) = takeSpan str pos sp + in (Map.insert k (reverse val) new, rem, newPos)) + (Map.empty, inp, mkRealSrcLoc (mkFastString "") 1 1) + where takeSpan :: StringBuffer -> RealSrcLoc -> RealSrcLoc -> (StringBuffer, String, RealSrcLoc) + takeSpan str pos end = takeSpan' end (str,"", pos) + + takeSpan' :: RealSrcLoc -> (StringBuffer, String, RealSrcLoc) -> (StringBuffer, String, RealSrcLoc) + takeSpan' end (sb, taken, pos) | (srcLocLine pos `compare` srcLocLine end) `thenCmp` (srcLocCol pos `compare` srcLocCol end) == LT && not (atEnd sb) + = let (c,rem) = nextChar sb in takeSpan' end (rem, c:taken, advanceSrcLoc pos c) + takeSpan' _ (rem, taken, pos) = (rem, taken, pos) + + thenCmp EQ o2 = o2 + thenCmp o1 _ = o1 + -- | Replaces the ranges in the AST with the source file parts applyFragments :: SourceInfoTraversal node => [String] -> Ann node dom RngTemplateStage -> Ann node dom SrcTemplateStage applyFragments srcs = flip evalState srcs . sourceInfoTraverseDown (SourceInfoTrf (\ni -> do template <- mapM getTextFor (ni ^. rngTemplateNodeElems) - return $ SourceTemplateNode (RealSrcSpan $ ni ^. rngTemplateNodeRange) template 0 Nothing) - (\(RangeTemplateList rng bef aft sep indented seps) - -> do (own, rest) <- splitAt (length seps) <$> get + return $ SourceTemplateNode (RealSrcSpan $ ni ^. rngTemplateNodeRange) (concat template) 0 Nothing) + (\(RangeTemplateList rng bef aft sep indented seps) + -> do (own, rest) <- splitAt (length seps) <$> get put rest - return (SourceTemplateList (RealSrcSpan rng) bef aft sep indented own 0 Nothing)) - (\(RangeTemplateOpt rng bef aft) -> return (SourceTemplateOpt (RealSrcSpan rng) bef aft 0 Nothing))) + return (SourceTemplateList (RealSrcSpan rng) bef aft sep indented (Prelude.zip (Prelude.map ((:[]) . NormalText) own) (Prelude.map RealSrcSpan seps)) 0 Nothing)) + (\(RangeTemplateOpt rng bef aft) -> return (SourceTemplateOpt (RealSrcSpan rng) bef aft 0 Nothing))) (return ()) (return ()) - where getTextFor RangeChildElem = return ChildElem - getTextFor (RangeElem _) = do (src:rest) <- get - put rest - return (TextElem src) \ No newline at end of file + where getTextFor RangeChildElem = return [ChildElem] + getTextFor (RangeElem rng) = do (src:rest) <- get + put rest + return [TextElem [NormalText src] (RealSrcSpan rng)] + +-- | Marks template elements in the AST that should always be present in the source code, regardless of their +-- containing elements being deleted. +-- Currently it recognizes CPP pragmas (lines starting with #) +-- This function should only be applied to an AST if CPP is enabled. +extractStayingElems :: SourceInfoTraversal node => Ann node dom SrcTemplateStage -> Ann node dom SrcTemplateStage +extractStayingElems = runIdentity . sourceInfoTraverse (SourceInfoTrf + (sourceTemplateNodeElems & traversal & sourceTemplateTextElem !- breakStaying) + (srcTmpSeparators & traversal & _1 !- breakStaying) + pure) + + where -- splits the elements into separate lines and then recombines them + breakStaying :: [SourceTemplateTextElem] -> [SourceTemplateTextElem] + breakStaying = concat . Prelude.map (\(NormalText s) -> toTxtElems s) + + toTxtElems :: String -> [SourceTemplateTextElem] + toTxtElems str = extractStaying $ splitOn "\n" $ str + where + extractStaying lines | not (any ("#" `isPrefixOf`) lines) = [NormalText str] + extractStaying lines = Prelude.foldr appendTxt [] + $ Prelude.map (\ln -> if "#" `isPrefixOf` ln then StayingText ln "\n" else NormalText ln) lines + -- recombines the lines if they are both normal text + -- otherwise it moves the windows '\r' characters to the correct position + appendTxt (NormalText n1) (NormalText n2 : rest) = NormalText (n1 ++ '\n':n2) : rest + appendTxt e (next@NormalText{} : ls) = case reverse (e ^. sourceTemplateText) of + -- fix '\r' characters that are separated from '\n' + '\r':_ -> ((sourceTemplateText .- init) . (lineEndings .= "\r\n") $ e) : (sourceTemplateText .- ("\r\n" ++) $ next) : ls + _ -> e : (sourceTemplateText .- ('\n':) $ next) : ls + appendTxt e (next : ls) = case reverse (e ^. sourceTemplateText) of + -- fix '\r' characters that are separated from '\n' + '\r':_ -> ((sourceTemplateText .- init) . (lineEndings .= "\r\n") $ e) : NormalText "\r\n" : next : ls + _ -> e : NormalText "\n" : next : ls + appendTxt e [] = [e] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs 2017-06-14 16:16:01.000000000 +0200 @@ -11,7 +11,7 @@ import Control.Monad.State import Control.Reference ((^.)) import Data.List -import Data.Maybe (Maybe(..), maybe, mapMaybe) +import Data.Maybe (Maybe(..), mapMaybe) import FastString as GHC (unpackFS) import SrcLoc @@ -20,17 +20,17 @@ -- | Creates a source template from the ranges and the input file. -- All source ranges must be good ranges. -cutUpRanges :: forall node dom . SourceInfoTraversal node +cutUpRanges :: forall node dom . SourceInfoTraversal node => Ann node dom NormRangeStage -> Ann node dom RngTemplateStage cutUpRanges n = evalState (cutUpRanges' n) [[],[]] where cutUpRanges' :: Ann node dom NormRangeStage -> State [[SrcSpan]] (Ann node dom RngTemplateStage) cutUpRanges' = sourceInfoTraverseUp (SourceInfoTrf (trf cutOutElemSpan) (trf cutOutElemList) (trf cutOutElemOpt)) desc asc - + -- keep the stack to contain the children elements on the place of the parent element desc = modify ([]:) asc = modify tail - + -- combine the current node with its children, and add it to the list of current nodes trf :: HasRange (x RngTemplateStage) => ([SrcSpan] -> x NormRangeStage -> x RngTemplateStage) -> x NormRangeStage -> State [[SrcSpan]] (x RngTemplateStage) @@ -44,12 +44,12 @@ cutOutElemSpan sps (NormNodeInfo (RealSrcSpan sp)) = RangeTemplateNode sp $ foldl breakFirstHit (foldl breakFirstHit [RangeElem sp] loc) span where (loc,span) = partition (\sp -> srcSpanStart sp == srcSpanEnd sp) sps - breakFirstHit (elem:rest) sp + breakFirstHit (elem:rest) sp = case breakUpRangeElem elem sp of -- only continue if the correct place for the child range is not found Just pieces -> pieces ++ rest Nothing -> elem : breakFirstHit rest sp - breakFirstHit [] sp = error ("breakFirstHit: " ++ maybe "" unpackFS (srcSpanFileName_maybe sp) ++ " didn't find correct place for " ++ shortShowSpan sp ++ " in " ++ shortShowSpan sp ++ " with [" ++ concat (intersperse "," (map shortShowSpan sps)) ++ "]") + breakFirstHit [] inner = error ("breakFirstHit: " ++ unpackFS (srcSpanFile sp) ++ " didn't find correct place for " ++ shortShowSpan inner ++ " in " ++ shortShowSpan (RealSrcSpan sp) ++ " with [" ++ concat (intersperse "," (map shortShowSpan sps)) ++ "]") cutOutElemSpan _ (NormNodeInfo (UnhelpfulSpan {})) = error "cutOutElemSpan: no real span" cutOutElemList :: [SrcSpan] -> ListInfo NormRangeStage -> ListInfo RngTemplateStage @@ -63,9 +63,9 @@ = mapMaybe getRangeElemSpan (cutOutElemSpan infos (NormNodeInfo (RealSrcSpan sp)) ^. rngTemplateNodeElems) -- at least two elements needed or there can be no separators getSeparators _ _ = [] - + cutOutElemOpt :: [SrcSpan] -> OptionalInfo NormRangeStage -> OptionalInfo RngTemplateStage -cutOutElemOpt sps (NormOptInfo bef aft sp) +cutOutElemOpt sps (NormOptInfo bef aft sp) = let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps in RangeTemplateOpt wholeRange bef aft @@ -73,49 +73,49 @@ -- if it is inside the range of the template element. Returns Nothing if the second argument is not inside. breakUpRangeElem :: RangeTemplateElem -> SrcSpan -> Maybe [RangeTemplateElem] breakUpRangeElem (RangeElem outer) (RealSrcSpan inner) - | outer `containsSpan` inner - = Just $ (if (realSrcSpanStart outer) < (realSrcSpanStart inner) + | outer `containsSpan` inner + = Just $ (if (realSrcSpanStart outer) < (realSrcSpanStart inner) then [ RangeElem (mkRealSrcSpan (realSrcSpanStart outer) (realSrcSpanStart inner)) ] else []) ++ [ RangeChildElem ] ++ - (if (realSrcSpanEnd inner) < (realSrcSpanEnd outer) + (if (realSrcSpanEnd inner) < (realSrcSpanEnd outer) then [ RangeElem (mkRealSrcSpan (realSrcSpanEnd inner) (realSrcSpanEnd outer)) ] else []) breakUpRangeElem _ _ = Nothing -- | Modifies ranges to contain their children -fixRanges :: SourceInfoTraversal node - => Ann node dom RangeStage +fixRanges :: SourceInfoTraversal node + => Ann node dom RangeStage -> Ann node dom NormRangeStage fixRanges node = evalState (sourceInfoTraverseUp (SourceInfoTrf (trf expandToContain) (trf expandListToContain) (trf expandOptToContain)) desc asc node) [[],[]] where -- keep the stack to contain the children elements on the place of the parent element desc = modify ([]:) asc = modify tail - + trf :: HasRange (x NormRangeStage) => ([SrcSpan] -> x RangeStage -> x NormRangeStage) -> x RangeStage -> State [[SrcSpan]] (x NormRangeStage) trf f ni = do (below : top : xs) <- get let res = f below ni resRange = getRange res endOfSiblings = srcSpanEnd (collectSpanRanges (srcSpanStart resRange) top) - correctedRange = if endOfSiblings > srcSpanStart resRange - then mkSrcSpan endOfSiblings (max endOfSiblings (srcSpanEnd resRange)) + correctedRange = if endOfSiblings > srcSpanStart resRange + then mkSrcSpan endOfSiblings (max endOfSiblings (srcSpanEnd resRange)) else resRange put ([] : (top ++ [ correctedRange ]) : xs) return $ setRange correctedRange res -- | Expand a simple node to contain its children expandToContain :: [SrcSpan] -> SpanInfo RangeStage -> SpanInfo NormRangeStage -expandToContain cont (NodeSpan sp) +expandToContain cont (NodeSpan sp) = NormNodeInfo (checkSpans cont $ foldl1 combineSrcSpans $ sp : cont) expandListToContain :: [SrcSpan] -> ListInfo RangeStage -> ListInfo NormRangeStage -expandListToContain cont (ListPos bef aft def ind sp) +expandListToContain cont (ListPos bef aft def ind sp) = NormListInfo bef aft def ind (checkSpans cont $ collectSpanRanges sp cont) expandOptToContain :: [SrcSpan] -> OptionalInfo RangeStage -> OptionalInfo NormRangeStage -expandOptToContain cont (OptionalPos bef aft sp) +expandOptToContain cont (OptionalPos bef aft sp) = NormOptInfo bef aft (checkSpans cont $ collectSpanRanges sp cont) collectSpanRanges :: SrcLoc -> [SrcSpan] -> SrcSpan @@ -124,8 +124,7 @@ -- | Checks the contained source ranges to detect the convertion problems where we can see their location. checkSpans :: [SrcSpan] -> SrcSpan -> SrcSpan -checkSpans spans res - = if any (not . isGoodSrcSpan) spans && isGoodSrcSpan res +checkSpans spans res + = if any (not . isGoodSrcSpan) spans && isGoodSrcSpan res then error $ "Wrong src spans in " ++ show res else res - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs 2017-05-03 22:13:56.000000000 +0200 @@ -5,7 +5,7 @@ , RecordWildCards , TypeFamilies #-} --- | The final version of the source annotation. Each node contains its original textual format, with the places of +-- | The final version of the source annotation. Each node contains its original textual format, with the places of -- the children specified by placeholders. module Language.Haskell.Tools.Transform.SourceTemplate where @@ -15,25 +15,25 @@ import SrcLoc instance SourceInfo SrcTemplateStage where - data SpanInfo SrcTemplateStage + data SpanInfo SrcTemplateStage = SourceTemplateNode { _sourceTemplateNodeRange :: SrcSpan -- ^ The (original) range of the given element , _sourceTemplateNodeElems :: [SourceTemplateElem] -- ^ The children of the given node, could be text or child nodes , _srcTmpMinInd :: Int -- ^ Minimum indentation for the element , _srcTmpRelPos :: Maybe Int -- ^ Relative indentation for newly created elements } deriving (Eq, Ord, Data) - data ListInfo SrcTemplateStage + data ListInfo SrcTemplateStage = SourceTemplateList { _sourceTemplateListRange :: SrcSpan -- ^ The (original) range of the given element , _srcTmpListBefore :: String -- ^ Text that should be put before the first element if the list becomes populated , _srcTmpListAfter :: String -- ^ Text that should be put after the last element if the list becomes populated , _srcTmpDefaultSeparator :: String -- ^ The default separator if the list were empty - , _srcTmpIndented :: Bool -- ^ True, if the elements need to be aligned in the same column - , _srcTmpSeparators :: [String] -- ^ The actual separators that were found in the source code + , _srcTmpIndented :: Maybe [Bool] -- ^ False for elements that should be not aligned + , _srcTmpSeparators :: [([SourceTemplateTextElem], SrcSpan)] -- ^ The actual separators that were found in the source code , _srcTmpListMinInd :: Int -- ^ Minimum indentation for the element , _srcTmpListRelPos :: Maybe Int -- ^ Relative indentation for newly created elements } deriving (Eq, Ord, Data) - data OptionalInfo SrcTemplateStage + data OptionalInfo SrcTemplateStage = SourceTemplateOpt { _sourceTemplateOptRange :: SrcSpan -- ^ The (original) range of the given element , _srcTmpOptBefore :: String -- ^ Text that should be put before the element if it appears , _srcTmpOptAfter :: String -- ^ Text that should be put after the element if it appears @@ -70,10 +70,10 @@ srcTmpDefaultSeparator :: Simple Lens (ListInfo SrcTemplateStage) String srcTmpDefaultSeparator = lens _srcTmpDefaultSeparator (\v s -> s { _srcTmpDefaultSeparator = v }) -srcTmpIndented :: Simple Lens (ListInfo SrcTemplateStage) Bool +srcTmpIndented :: Simple Lens (ListInfo SrcTemplateStage) (Maybe [Bool]) srcTmpIndented = lens _srcTmpIndented (\v s -> s { _srcTmpIndented = v }) -srcTmpSeparators :: Simple Lens (ListInfo SrcTemplateStage) [String] +srcTmpSeparators :: Simple Lens (ListInfo SrcTemplateStage) [([SourceTemplateTextElem], SrcSpan)] srcTmpSeparators = lens _srcTmpSeparators (\v s -> s { _srcTmpSeparators = v }) srcTmpListMinimalIndent :: Simple Lens (ListInfo SrcTemplateStage) Int @@ -95,39 +95,54 @@ srcTmpOptMinimalIndent :: Simple Lens (OptionalInfo SrcTemplateStage) Int srcTmpOptMinimalIndent = lens _srcTmpOptMinInd (\v s -> s { _srcTmpOptMinInd = v }) - + srcTmpOptRelPos :: Simple Lens (OptionalInfo SrcTemplateStage) (Maybe Int) srcTmpOptRelPos = lens _srcTmpOptRelPos (\v s -> s { _srcTmpOptRelPos = v }) - + -- | An element of a source template for a singleton AST node. data SourceTemplateElem - = TextElem { _sourceTemplateText :: String } -- ^ Source text belonging to the current node + = TextElem { _sourceTemplateTextElem :: [SourceTemplateTextElem] + , _sourceTemplateTextRange :: SrcSpan + } -- ^ Source text belonging to the current node | ChildElem -- ^ Placeholder for the next children of the node deriving (Eq, Ord, Data) +isStayingText :: SourceTemplateTextElem -> Bool +isStayingText StayingText{} = True +isStayingText _ = False + +data SourceTemplateTextElem + = NormalText { _sourceTemplateText :: String } + | StayingText { _sourceTemplateText :: String, _lineEndings :: String } + deriving (Eq, Ord, Data) + makeReferences ''SourceTemplateElem +makeReferences ''SourceTemplateTextElem -instance HasRange (SpanInfo SrcTemplateStage) where - getRange = (^. sourceTemplateNodeRange) - setRange = (sourceTemplateNodeRange .=) - -instance HasRange (ListInfo SrcTemplateStage) where - getRange = (^. sourceTemplateListRange) - setRange = (sourceTemplateListRange .=) - -instance HasRange (OptionalInfo SrcTemplateStage) where +instance HasRange (SpanInfo SrcTemplateStage) where + getRange = (^. sourceTemplateNodeRange) + setRange = (sourceTemplateNodeRange .=) + +instance HasRange (ListInfo SrcTemplateStage) where + getRange = (^. sourceTemplateListRange) + setRange = (sourceTemplateListRange .=) + +instance HasRange (OptionalInfo SrcTemplateStage) where getRange = (^. sourceTemplateOptRange) - setRange = (sourceTemplateOptRange .=) - + setRange = (sourceTemplateOptRange .=) + instance Show (SpanInfo SrcTemplateStage) where show (SourceTemplateNode _ sp _ _) = concatMap show sp instance Show (ListInfo SrcTemplateStage) where - show SourceTemplateList{..} = "<*" ++ show _srcTmpListBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpListAfter ++ "*>" + show SourceTemplateList{..} = "<*" ++ show _srcTmpListBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpListAfter ++ " " ++ show _srcTmpSeparators ++ "*>" instance Show (OptionalInfo SrcTemplateStage) where show SourceTemplateOpt{..} = "<?" ++ show _srcTmpOptBefore ++ " " ++ show _srcTmpOptAfter ++ "?>" instance Show SourceTemplateElem where - show (TextElem s) = s + show (TextElem s _) = show s show ChildElem = "<.>" +instance Show SourceTemplateTextElem where + show (NormalText s) = show s + show (StayingText s _) = "|" ++ show s ++ "|" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs 2017-05-03 22:13:56.000000000 +0200 @@ -16,7 +16,7 @@ type ASTMulti node dom = AnnListG node dom SrcTemplateStage instance IsString (SpanInfo SrcTemplateStage) where - fromString s = SourceTemplateNode noSrcSpan [TextElem s] 0 Nothing + fromString s = SourceTemplateNode noSrcSpan [TextElem [NormalText s] noSrcSpan] 0 Nothing -- * Basic elements child :: SpanInfo SrcTemplateStage @@ -26,7 +26,7 @@ opt = SourceTemplateOpt noSrcSpan "" "" 0 Nothing list :: ListInfo SrcTemplateStage -list = SourceTemplateList noSrcSpan "" "" "" False [] 0 Nothing +list = SourceTemplateList noSrcSpan "" "" "" Nothing [] 0 Nothing -- * Modifiers @@ -77,7 +77,7 @@ -- | The elements of the list should be indented on the same column indented :: ListInfo SrcTemplateStage -> ListInfo SrcTemplateStage -indented = (srcTmpIndented .= True) . (srcTmpDefaultSeparator .= "\n") +indented = (srcTmpIndented .= Just []) . (srcTmpDefaultSeparator .= "\n") -- | Concatenates two source templates to produce a new template with all child elements. (<>) :: SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform.hs 2017-05-24 22:37:50.000000000 +0200 @@ -1,6 +1,6 @@ -- | A module for preparing the representation of the AST for pretty printing. module Language.Haskell.Tools.Transform - ( prepareAST + ( prepareAST, prepareASTCpp -- comment handling , placeComments, getNormalComments, getPragmaComments -- generating source templates @@ -9,20 +9,32 @@ , sourceTemplateNodeRange, sourceTemplateNodeElems , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter + , SourceTemplateElem(..), sourceTemplateTextElem, sourceTemplateTextRange, SourceTemplateTextElem(..), sourceTemplateText, lineEndings, isStayingText -- parts of the transformation, used for debugging purposes - , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices + , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices, fixMainRange, extractStayingElems ) where import Language.Haskell.Tools.Transform.PlaceComments (getNormalComments, getPragmaComments, placeComments) import Language.Haskell.Tools.Transform.RangeTemplate () -import Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate (rangeToSource, getLocIndices, mapLocIndices) +import Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate (rangeToSource, getLocIndices, mapLocIndices, extractStayingElems) import Language.Haskell.Tools.Transform.RangeToRangeTemplate (cutUpRanges, fixRanges) import Language.Haskell.Tools.Transform.SourceTemplate import Language.Haskell.Tools.Transform.SourceTemplateHelpers +import FastString (mkFastString) import Language.Haskell.Tools.AST -import StringBuffer (StringBuffer) +import SrcLoc +import StringBuffer (StringBuffer, nextChar, atEnd) -- | Prepares the AST for pretty printing -prepareAST :: SourceInfoTraversal node => StringBuffer -> Ann node dom RangeStage -> Ann node dom SrcTemplateStage +prepareAST :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom SrcTemplateStage prepareAST srcBuffer = rangeToSource srcBuffer . cutUpRanges . fixRanges + +prepareASTCpp :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom SrcTemplateStage +prepareASTCpp srcBuffer = extractStayingElems . rangeToSource srcBuffer . cutUpRanges . fixRanges . fixMainRange srcBuffer + +fixMainRange :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom RangeStage +fixMainRange buffer mod = setRange (mkSrcSpan (srcSpanStart $ getRange mod) (RealSrcLoc (endPos startPos buffer))) mod + where startPos = mkRealSrcLoc (mkFastString "") 1 1 + endPos pos buf | atEnd buf = pos + endPos pos buf = let (ch,buf') = nextChar buf in endPos (advanceSrcLoc pos ch) buf' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/haskell-tools-prettyprint.cabal new/haskell-tools-prettyprint-0.8.0.0/haskell-tools-prettyprint.cabal --- old/haskell-tools-prettyprint-0.5.0.0/haskell-tools-prettyprint.cabal 2017-01-31 20:55:48.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/haskell-tools-prettyprint.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-prettyprint -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Pretty printing of Haskell-Tools AST description: Converts the Haskell-Tools AST to text. Prepares the AST for this conversion. If the AST was created from the GHC AST this pretty printing will result in the original source code. Generated AST parts will get the default formatting. Works using the source annotations that are present in the AST. Creates a rose tree first to simplify the conversion. homepage: https://github.com/haskell-tools/haskell-tools @@ -12,7 +12,7 @@ cabal-version: >=1.10 library - ghc-options: -O2 + ghc-options: -O2 exposed-modules: Language.Haskell.Tools.PrettyPrint , Language.Haskell.Tools.Transform , Language.Haskell.Tools.IndentationUtils @@ -29,6 +29,7 @@ , references >= 0.3 && < 0.4 , uniplate >= 1.6 && < 1.7 , split >= 0.2 && < 0.3 + , text >= 1.2 && < 1.3 , ghc >= 8.0 && < 8.1 - , haskell-tools-ast >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , haskell-tools-ast >= 0.8 && < 0.9 + default-language: Haskell2010

1 0

commit ghc-haskell-tools-demo for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-demo for openSUSE:Factory checked in at 2017-08-31 20:56:04 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-demo (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-demo.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-demo" Thu Aug 31 20:56:04 2017 rev:2 rq:513373 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-demo/ghc-haskell-tools-demo.changes 2017-04-12 18:06:45.838150689 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-demo.new/ghc-haskell-tools-demo.changes 2017-08-31 20:56:06.042474906 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-demo-0.5.0.0.tar.gz New: ---- haskell-tools-demo-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-demo.spec ++++++ --- /var/tmp/diff_new_pack.T1hxQe/_old 2017-08-31 20:56:06.774372073 +0200 +++ /var/tmp/diff_new_pack.T1hxQe/_new 2017-08-31 20:56:06.790369825 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-demo %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: A web-based demo for Haskell-tools Refactor License: BSD-3-Clause ++++++ haskell-tools-demo-0.5.0.0.tar.gz -> haskell-tools-demo-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/haskell-tools-demo.cabal new/haskell-tools-demo-0.8.0.0/haskell-tools-demo.cabal --- old/haskell-tools-demo-0.5.0.0/haskell-tools-demo.cabal 2017-01-31 20:57:57.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/haskell-tools-demo.cabal 2017-07-01 12:51:24.000000000 +0200 @@ -1,6 +1,6 @@ name: haskell-tools-demo -version: 0.5.0.0 -synopsis: A web-based demo for Haskell-tools Refactor. +version: 0.8.0.0 +synopsis: A web-based demo for Haskell-tools Refactor. description: Allows websocket clients to connect and performs refactorings on demand. The clients maintain a continous connection with the server, sending changes in the source files. When a refactor request is received, it performs the changes and sends the modified source files to the client. homepage: https://github.com/haskell-tools/haskell-tools license: BSD3 @@ -11,9 +11,8 @@ build-type: Simple cabal-version: >=1.10 -library +library hs-source-dirs: src - ghc-options: -O2 exposed-modules: Language.Haskell.Tools.Demo other-modules: Language.Haskell.Tools.ASTDebug , Language.Haskell.Tools.ASTDebug.Instances @@ -22,38 +21,38 @@ , transformers >= 0.5 && < 0.6 , directory >= 1.2 && < 1.4 , containers >= 0.5 && < 0.6 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 0.11 , http-types >= 0.9 && < 0.10 , warp >= 3.2 && < 3.3 , wai >= 3.2 && < 3.3 - , websockets >= 0.10 && < 0.11 + , websockets >= 0.10 && < 0.12 , wai-websockets >= 3.0 && < 3.1 , references >= 0.3 && < 0.4 - , ghc >= 8.0 && < 8.1 + , ghc >= 8.0.2 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , filepath >= 1.4 && < 1.5 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-backend-ghc >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-backend-ghc >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 default-language: Haskell2010 executable ht-demo main-is: Main.hs hs-source-dirs: exe - ghc-options: -with-rtsopts=-M1500m -O2 + ghc-options: -with-rtsopts=-M1500m build-depends: base >= 4.9 && < 4.10 - , haskell-tools-demo >= 0.5 && < 0.6 + , haskell-tools-demo >= 0.8 && < 0.9 default-language: Haskell2010 test-suite haskell-tools-demo-tests type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2g -O2 + ghc-options: -with-rtsopts=-M2g hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: base >= 4.9 && < 4.10 - , HUnit >= 1.5 && < 1.6 + , HUnit >= 1.5 && < 1.7 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 @@ -61,6 +60,6 @@ , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 , websockets >= 0.10 && < 0.11 - , aeson >= 1.0 && < 1.2 - , haskell-tools-demo >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , aeson >= 1.0 && < 1.3 + , haskell-tools-demo >= 0.8 && < 0.9 + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs 2017-05-17 10:56:29.000000000 +0200 @@ -3,7 +3,7 @@ , MultiParamTypeClasses , StandaloneDeriving , DeriveGeneric - , UndecidableInstances + , UndecidableInstances , TypeFamilies #-} module Language.Haskell.Tools.ASTDebug.Instances where @@ -40,7 +40,7 @@ instance (ASTDebug e dom st) => ASTDebug (AnnListG e) dom st where astDebug' (AnnListG a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] - + instance (ASTDebug e dom st) => ASTDebug (AnnMaybeG e) dom st where astDebug' (AnnMaybeG a e) = [TreeNode "" (TreeDebugNode "?" (DefaultInfoType (getRange (a ^. sourceInfo))) (maybe [] astDebug' e))] @@ -103,6 +103,7 @@ instance (Domain dom, SourceInfo st) => ASTDebug UBracket dom st instance (Domain dom, SourceInfo st) => ASTDebug UTopLevelPragma dom st instance (Domain dom, SourceInfo st) => ASTDebug URule dom st +instance (Domain dom, SourceInfo st) => ASTDebug URuleVar dom st instance (Domain dom, SourceInfo st) => ASTDebug UAnnotationSubject dom st instance (Domain dom, SourceInfo st) => ASTDebug UMinimalFormula dom st instance (Domain dom, SourceInfo st) => ASTDebug UExprPragma dom st @@ -131,6 +132,7 @@ instance (Domain dom, SourceInfo st) => ASTDebug ULanguageExtension dom st instance (Domain dom, SourceInfo st) => ASTDebug UMatchLhs dom st instance (Domain dom, SourceInfo st) => ASTDebug UInlinePragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug USpecializePragma dom st -- ULiteral instance (Domain dom, SourceInfo st) => ASTDebug ULiteral dom st diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug.hs 2017-05-22 15:12:54.000000000 +0200 @@ -53,11 +53,11 @@ deriving instance Domain dom => Show (TreeDebugNode dom) -data SemanticInfoType dom - = DefaultInfoType { semaInfoTypeRng :: SrcSpan +data SemanticInfoType dom + = DefaultInfoType { semaInfoTypeRng :: SrcSpan } | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls - , semaInfoTypeRng :: SrcSpan + , semaInfoTypeRng :: SrcSpan } | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls , semaInfoTypeRng :: SrcSpan @@ -88,7 +88,7 @@ astDebugToJson :: AssocSema dom => [DebugNode dom] -> Seq Char astDebugToJson nodes = fromList "[ " >< childrenJson >< fromList " ]" where treeNodes = List.filter (\case TreeNode {} -> True; _ -> False) nodes - childrenJson = case map debugTreeNode treeNodes of + childrenJson = case map debugTreeNode treeNodes of first:rest -> first >< foldl (><) Seq.empty (fmap (fromList ", " ><) (fromList rest)) [] -> Seq.empty debugTreeNode (TreeNode "" s) = astDebugElemJson s @@ -96,20 +96,20 @@ debugTreeNode (SimpleNode {}) = error "debugTreeNode: simple SimpleNode not allowed" astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char -astDebugElemJson (TreeDebugNode name info children) - = fromList "{ \"text\" : \"" >< fromList name - >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" +astDebugElemJson (TreeDebugNode name info children) + = fromList "{ \"text\" : \"" >< fromList name + >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" >< fromList (shortShowSpan (semaInfoTypeRng info)) - >< fromList "\", \"data-elems\" : \"" + >< fromList "\", \"data-elems\" : \"" >< foldl (><) Seq.empty dataElems - >< fromList "\", \"data-sema\" : \"" + >< fromList "\", \"data-sema\" : \"" >< fromList (showSema info) - >< fromList "\" }, \"children\" : " + >< fromList "\" }, \"children\" : " >< astDebugToJson children >< fromList " }" where dataElems = catMaybes (map (\case SimpleNode l v -> Just (fromList (formatScalarElem l v)); _ -> Nothing) children) formatScalarElem l v = "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ tail (init (show v)) ++ "</div>" - showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" - ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) + showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" + ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) class AssocData a where assocName :: a -> String @@ -140,15 +140,15 @@ toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni)) , ("isDefined", show (semanticsDefining ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance AssocData CNameInfo where assocName _ = "CNameInfo" toAssoc ni = [ ("name", inspect (semanticsId ni)) , ("isDefined", show (semanticsDefining ni)) - , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance (HasModuleInfo' (ModuleInfo n)) => AssocData (ModuleInfo n) where @@ -157,25 +157,28 @@ , ("isBoot", show (isBootModule mi)) , ("implicitImports", concat (intersperse ", " (map inspect (semanticsImplicitImports mi)))) ] - + instance (HasImportInfo' (ImportInfo n)) => AssocData (ImportInfo n) where assocName _ = "ImportInfo" - toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) - , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) - , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) - ] - + toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) + , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) + , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) + ] + instance AssocData ImplicitFieldInfo where assocName _ = "ImplicitFieldInfo" toAssoc ifi = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") (semanticsImplicitFlds ifi)))) - ] + ] -inspectScope :: InspectableName n => [[n]] -> String +inspectScope :: InspectableName n => [[(n, Maybe [UsageSpec])]] -> String inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect) class InspectableName n where inspect :: n -> String +instance InspectableName n => InspectableName (n, Maybe [UsageSpec]) where + inspect (n,usage) = inspect n ++ showSDocUnsafe (ppr usage) + instance InspectableName GHC.Name where inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" @@ -193,35 +196,35 @@ | Just (_, t') <- splitForAllTy_maybe t = getTVs t' | otherwise = [] -class (Domain dom, SourceInfo st) +class (Domain dom, SourceInfo st) => ASTDebug e dom st where astDebug' :: e dom st -> [DebugNode dom] default astDebug' :: (GAstDebug (Rep (e dom st)) dom, Generic (e dom st)) => e dom st -> [DebugNode dom] astDebug' = gAstDebug . from -class GAstDebug f dom where +class GAstDebug f dom where gAstDebug :: f p -> [DebugNode dom] - + instance GAstDebug V1 dom where gAstDebug _ = error "GAstDebug V1" - + instance GAstDebug U1 dom where - gAstDebug U1 = [] - + gAstDebug U1 = [] + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :+: g) dom where gAstDebug (L1 x) = gAstDebug x gAstDebug (R1 x) = gAstDebug x - + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :*: g) dom where - gAstDebug (x :*: y) + gAstDebug (x :*: y) = gAstDebug x ++ gAstDebug y instance {-# OVERLAPPING #-} ASTDebug e dom st => GAstDebug (K1 i (e dom st)) dom where gAstDebug (K1 x) = astDebug' x - + instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) dom where gAstDebug (K1 x) = [SimpleNode "" (show x)] - + instance (GAstDebug f dom, Constructor c) => GAstDebug (M1 C c f) dom where gAstDebug c@(M1 x) = [TreeNode "" (TreeDebugNode (conName c) undefined (gAstDebug x))] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/Demo.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/Demo.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/Demo.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/Demo.hs 2017-06-07 10:55:20.000000000 +0200 @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings - , DeriveGeneric + , DeriveGeneric , TypeApplications , TupleSections , ScopedTypeVariables @@ -52,13 +52,13 @@ import Language.Haskell.Tools.PrettyPrint import Language.Haskell.Tools.Refactor.Perform import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.RefactorBase hiding (initSession) type ClientId = Int data RefactorSessionState - = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom) - , _actualMod :: Maybe (String, String, IsBoot) + = RefactorSessionState { _refSessMods :: Map.Map (String, String, FilePath) (UnnamedModule IdDom) + , _actualMod :: Maybe (String, String, FilePath) , _isDisconnecting :: Bool } @@ -75,7 +75,7 @@ wd <- case args of dir:_ -> return dir [] -> return "." counter <- newMVar [] - let settings = setPort 8206 $ setTimeout 20 $ defaultSettings + let settings = setPort 8206 $ setTimeout 20 $ defaultSettings runSettings settings (app counter wd) -- | The application that is evoked for each incoming request @@ -96,10 +96,10 @@ do Text msg <- receiveDataMessage conn respondTo wd sessId ghcSess state (sendTextData conn) msg currState <- readMVar state - if currState ^. isDisconnecting + if currState ^. isDisconnecting then sendClose conn ("" :: ByteString) else serverLoop sessId ghcSess state conn - `catch` \(_ :: ConnectionException) -> do + `catch` \(_ :: ConnectionException) -> do modifyMVar_ sessions (return . delete sessId) liftIO $ removeDirectoryIfPresent (userDir wd sessId) @@ -129,9 +129,9 @@ return Nothing updateClient dir (ModuleDeleted name) = do lift $ removeTarget (TargetModule (GHC.mkModuleName name)) - modify $ refSessMods .- Map.delete (dir, name, NormalHs) + modify $ refSessMods .- Map.delete (dir, name, dir </> moduleSourceFile name) return Nothing -updateClient dir (InitialProject modules) = do +updateClient dir (InitialProject modules) = do -- clean the workspace to remove source files from earlier sessions liftIO $ removeDirectoryIfPresent dir liftIO $ createDirectoryIfMissing True dir @@ -148,24 +148,29 @@ updateClient dir (PerformRefactoring refact modName selection args) = do mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) allModules <- gets (filter ((modName /=) . (^. sfkModuleName) . fst) . map moduleNameAndContent . Map.assocs . (^. refSessMods)) - let command = analyzeCommand refact (selection:args) - case mod of Just m -> do res <- lift $ performCommand command (moduleNameAndContent m) allModules - case res of - Left err -> return $ Just $ ErrorMessage err - Right diff -> do applyChanges diff - return $ Just $ RefactorChanges (map trfDiff diff) - Nothing -> return $ Just $ ErrorMessage "The module is not found" + case analyzeCommand refact (selection:args) of + Right command -> + case mod of Just m -> do res <- lift $ performCommand command (moduleNameAndContent m) allModules + case res of + Left err -> return $ Just $ ErrorMessage err + Right diff -> do applyChanges diff + return $ Just $ RefactorChanges (map trfDiff diff) + Nothing -> return $ Just $ ErrorMessage "The module is not found" + Left err -> return $ Just $ ErrorMessage err where trfDiff (ContentChanged (key,cont)) = (key ^. sfkModuleName, Just (prettyPrint cont)) trfDiff (ModuleCreated name mod _) = (name, Just (prettyPrint mod)) trfDiff (ModuleRemoved name) = (name, Nothing) applyChanges diff - = do forM_ diff $ \case - ModuleCreated n m _ -> writeModule n m - ContentChanged (n,m) -> writeModule (n ^. sfkModuleName) m + = do forM_ diff $ \case + ModuleCreated n m _ -> do + writeModule n m + lift $ addTarget (Target (TargetModule (GHC.mkModuleName n)) True Nothing) + ContentChanged (n,m) -> + writeModule (n ^. sfkModuleName) m ModuleRemoved mod -> do liftIO $ removeFile (toFileName dir mod) - modify $ refSessMods .- Map.delete (dir, mod, NormalHs) + modify $ refSessMods .- Map.delete (dir, mod, dir </> moduleSourceFile mod) lift $ removeTarget (TargetModule (GHC.mkModuleName mod)) reloadAllMods dir @@ -173,22 +178,23 @@ reloadAllMods :: FilePath -> StateT RefactorSessionState Ghc () reloadAllMods dir = do + wd <- liftIO getCurrentDirectory void $ lift $ load LoadAllTargets targets <- lift getTargets forM_ (map ((\case (TargetModule n) -> n) . targetId) targets) $ \modName -> do - mod <- lift $ getModSummary modName >>= parseTyped - modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, NormalHs) mod + mod <- lift $ getModSummary modName >>= parseTyped wd + modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, dir </> moduleSourceFile (GHC.moduleNameString modName)) mod createFileForModule :: FilePath -> String -> String -> IO () createFileForModule dir name newContent = do let fname = toFileName dir name createDirectoryIfMissing True (takeDirectory fname) - withBinaryFile fname WriteMode (`hPutStr` newContent) + withBinaryFile fname WriteMode (`hPutStr` newContent) removeDirectoryIfPresent :: FilePath -> IO () removeDirectoryIfPresent dir = removeDirectoryRecursive dir `catch` \e -> if isDoesNotExistError e then return () else throwIO e -moduleNameAndContent :: ((String,String,IsBoot), mod) -> (SourceFileKey, mod) +moduleNameAndContent :: ((String,String,FilePath), mod) -> (SourceFileKey, mod) moduleNameAndContent ((_,name,isBoot), mod) = (SourceFileKey isBoot name, mod) dataDirs :: FilePath -> FilePath @@ -198,25 +204,30 @@ userDir wd id = dataDirs wd </> show id initGhcSession :: FilePath -> IO Session -initGhcSession workingDir +initGhcSession workingDir = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlagsForTest >> useDirs [workingDir] >> getSession)) handleErrors :: FilePath -> ClientMessage -> (ResponseMsg -> IO ()) -> IO () -> IO () handleErrors wd req next io = io `catch` (next <=< handleException) where handleException :: SomeException -> IO ResponseMsg - handleException e - | Just (se :: SourceError) <- fromException e - = return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) + handleException e + | Just (se :: SourceError) <- fromException e + = if isReloading + then do logToFile wd (show e) req + return $ ErrorMessage ("The generated code cannot be compiled. The problem had been reported. Please restart the demo or correct the results manually.") + else return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) | Just (ae :: AsyncException) <- fromException e = throw ae | Just (ge :: GhcException) <- fromException e = return $ ErrorMessage $ show ge | Just (re :: RefactorException) <- fromException e = return $ ErrorMessage $ displayException re | otherwise = do logToFile wd (show e) req return $ ErrorMessage (showInternalError e) - + showMsg msg = showSpan (errMsgSpan msg) ++ "\n" ++ show msg showSpan (RealSrcSpan sp) = showFileName (srcLocFile (realSrcSpanStart sp)) ++ " " ++ show (srcLocLine (realSrcSpanStart sp)) ++ ":" ++ show (srcLocCol (realSrcSpanStart sp)) showSpan _ = "" + isReloading = case req of PerformRefactoring {} -> True; _ -> False + showFileName = joinPath . drop 2 . splitPath . makeRelative wd . unpackFS showInternalError :: SomeException -> String @@ -228,8 +239,8 @@ withFile logFile AppendMode $ \handle -> do size <- hFileSize handle when (size < logSizeLimit) $ hPutStrLn handle ("\n### " ++ msg) - `catch` \e -> print ("The error message cannot be logged because: " - ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) + `catch` \e -> print ("The error message cannot be logged because: " + ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) where logFile = wd </> "error-log.txt" logSizeLimit = 100 * 1024 * 1024 -- 100 MB @@ -248,7 +259,7 @@ | Disconnect deriving (Show, Generic) -instance FromJSON ClientMessage +instance FromJSON ClientMessage data ResponseMsg = RefactorChanges { moduleChanges :: [(String, Maybe String)] }

1 0

commit ghc-haskell-tools-debug for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-debug for openSUSE:Factory checked in at 2017-08-31 20:56:00 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-debug (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-debug.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-debug" Thu Aug 31 20:56:00 2017 rev:2 rq:513372 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-debug/ghc-haskell-tools-debug.changes 2017-04-12 18:06:45.078258134 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-debug.new/ghc-haskell-tools-debug.changes 2017-08-31 20:56:04.310718224 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:41 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-debug-0.5.0.0.tar.gz New: ---- haskell-tools-debug-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-debug.spec ++++++ --- /var/tmp/diff_new_pack.78zVec/_old 2017-08-31 20:56:05.278582236 +0200 +++ /var/tmp/diff_new_pack.78zVec/_new 2017-08-31 20:56:05.282581674 +0200 @@ -18,7 +18,7 @@ %global pkg_name haskell-tools-debug Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Debugging Tools for Haskell-tools License: BSD-3-Clause @@ -27,6 +27,7 @@ Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: chrpath BuildRequires: ghc-Cabal-devel +BuildRequires: ghc-filepath-devel BuildRequires: ghc-ghc-devel BuildRequires: ghc-ghc-paths-devel BuildRequires: ghc-haskell-tools-ast-devel @@ -35,6 +36,7 @@ BuildRequires: ghc-haskell-tools-refactor-devel BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros +BuildRequires: ghc-template-haskell-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %description ++++++ haskell-tools-debug-0.5.0.0.tar.gz -> haskell-tools-debug-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/Debug.hs new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/Debug.hs --- old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/Debug.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/Debug.hs 2017-06-07 10:55:20.000000000 +0200 @@ -1,14 +1,21 @@ {-# LANGUAGE StandaloneDeriving , DeriveGeneric + , LambdaCase #-} module Language.Haskell.Tools.Debug where +import Control.Monad +import Control.Reference import Control.Monad.IO.Class (MonadIO(..)) import Data.Maybe (Maybe(..), fromJust) import GHC.Generics (Generic(..)) +import System.FilePath (pathSeparator, (</>), (<.>)) +import DynFlags (xopt) import GHC hiding (loadModule) import GHC.Paths ( libdir ) +import Language.Haskell.TH.LanguageExtensions (Extension(..)) +import StringBuffer (hGetStringBuffer) import Language.Haskell.Tools.AST (NodeInfo(..)) import Language.Haskell.Tools.AST.FromGHC @@ -17,24 +24,30 @@ import Language.Haskell.Tools.RangeDebug (srcInfoDebug) import Language.Haskell.Tools.RangeDebug.Instances () import Language.Haskell.Tools.Refactor.Perform (performCommand, readCommand) +import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase (RefactorChange(..), IsBoot(..), SourceFileKey(..)) +import Language.Haskell.Tools.Refactor.RefactorBase (RefactorChange(..), SourceFileKey(..)) import Language.Haskell.Tools.Transform -- | Should be only used for testing demoRefactor :: String -> String -> [String] -> String -> IO () -demoRefactor command workingDir args moduleName = +demoRefactor command workingDir args moduleName = runGhc (Just libdir) $ do initGhcFlags _ <- useFlags args useDirs [workingDir] - modSum <- loadModule workingDir moduleName + ms <- loadModule workingDir moduleName + let modSum = ms { ms_hspp_opts = (ms_hspp_opts ms) { hscTarget = HscAsm, ghcLink = LinkInMemory } } p <- parseModule modSum t <- typecheckModule p - + let annots = pm_annotations $ tm_parsed_module t + hasCPP = Cpp `xopt` ms_hspp_opts modSum - liftIO $ putStrLn $ show annots + liftIO $ putStrLn "=========== tokens:" + liftIO $ putStrLn $ show (fst annots) + liftIO $ putStrLn "=========== comments:" + liftIO $ putStrLn $ show (snd annots) liftIO $ putStrLn "=========== parsed source:" liftIO $ putStrLn $ show (pm_parsed_source p) liftIO $ putStrLn "=========== renamed source:" @@ -49,34 +62,45 @@ transformed <- addTypeInfos (typecheckedSource t) =<< (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename modSum parseTrf (fromJust $ tm_renamed_source t) (pm_parsed_source p)) liftIO $ putStrLn $ srcInfoDebug transformed liftIO $ putStrLn "=========== ranges fixed:" - let commented = fixRanges $ placeComments (getNormalComments $ snd annots) transformed + sourceOrigin <- if hasCPP then liftIO $ hGetStringBuffer (workingDir </> map (\case '.' -> pathSeparator; c -> c) moduleName <.> "hs") + else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) + let commented = fixRanges $ placeComments (fst annots) (getNormalComments $ snd annots) $ fixMainRange sourceOrigin transformed liftIO $ putStrLn $ srcInfoDebug commented liftIO $ putStrLn "=========== cut up:" let cutUp = cutUpRanges commented liftIO $ putStrLn $ srcInfoDebug cutUp liftIO $ putStrLn $ show $ getLocIndices cutUp - liftIO $ putStrLn $ show $ mapLocIndices (fromJust $ ms_hspp_buf $ pm_mod_summary p) (getLocIndices cutUp) + + liftIO $ putStrLn $ show $ mapLocIndices sourceOrigin (getLocIndices cutUp) liftIO $ putStrLn "=========== sourced:" - let sourced = rangeToSource (fromJust $ ms_hspp_buf $ pm_mod_summary p) cutUp + let sourced = (if hasCPP then extractStayingElems else id) $ rangeToSource sourceOrigin cutUp liftIO $ putStrLn $ srcInfoDebug sourced liftIO $ putStrLn "=========== pretty printed:" let prettyPrinted = prettyPrint sourced liftIO $ putStrLn prettyPrinted - transformed <- performCommand (readCommand command) ((SourceFileKey NormalHs moduleName), sourced) [] - case transformed of - Right [ContentChanged (_, correctlyTransformed)] -> do - liftIO $ putStrLn "=========== transformed AST:" - liftIO $ putStrLn $ srcInfoDebug correctlyTransformed - liftIO $ putStrLn "=========== transformed & prettyprinted:" - let prettyPrinted = prettyPrint correctlyTransformed - liftIO $ putStrLn prettyPrinted - liftIO $ putStrLn "===========" - -- TODO: implement - Right _ -> error "The output shoud be one module changed" + transformed <- performCommand (either error id $ readCommand command) ((SourceFileKey (moduleSourceFile moduleName) moduleName), sourced) [] + case transformed of + Right changes -> do + forM_ changes $ \case + ContentChanged (mod, correctlyTransformed) -> do + liftIO $ putStrLn $ "=========== transformed AST (" ++ (mod ^. sfkModuleName) ++ "):" + liftIO $ putStrLn $ srcInfoDebug correctlyTransformed + liftIO $ putStrLn $ "=========== transformed & prettyprinted (" ++ (mod ^. sfkModuleName) ++ "):" + let prettyPrinted = prettyPrint correctlyTransformed + liftIO $ putStrLn prettyPrinted + liftIO $ putStrLn "===========" + ModuleRemoved mod -> do + liftIO $ putStrLn $ "=========== module removed: " ++ mod + ModuleCreated mod cont _ -> do + liftIO $ putStrLn $ "=========== created AST (" ++ mod ++ "):" + liftIO $ putStrLn $ srcInfoDebug cont + liftIO $ putStrLn $ "=========== created & prettyprinted (" ++ mod ++ "):" + let prettyPrinted = prettyPrint cont + liftIO $ putStrLn prettyPrinted Left transformProblem -> do liftIO $ putStrLn "===========" liftIO $ putStrLn transformProblem liftIO $ putStrLn "===========" - + deriving instance Generic SrcSpan deriving instance Generic (NodeInfo sema src) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs --- old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs 2017-05-17 11:30:04.000000000 +0200 @@ -3,7 +3,7 @@ , MultiParamTypeClasses , StandaloneDeriving , DeriveGeneric - , UndecidableInstances + , UndecidableInstances #-} module Language.Haskell.Tools.RangeDebug.Instances where @@ -17,16 +17,16 @@ -- Annotations instance TreeDebug e dom st => TreeDebug (Ann e) dom st where treeDebug' i (Ann a e) = identLine i ++ show (a ^. sourceInfo) ++ " " ++ take 40 (show e) ++ "..." ++ treeDebug' (i+1) e - + identLine :: Int -> String identLine i = "\n" ++ replicate (i*2) ' ' - + instance TreeDebug e dom st => TreeDebug (AnnListG e) dom st where - treeDebug' i (AnnListG a ls) = identLine i ++ show (a ^. sourceInfo) ++ " <*>" ++ concatMap (treeDebug' (i + 1)) ls - + treeDebug' i (AnnListG a ls) = identLine i ++ show (a ^. sourceInfo) ++ " <*>" ++ concatMap (treeDebug' (i + 1)) ls + instance TreeDebug e dom st => TreeDebug (AnnMaybeG e) dom st where treeDebug' i (AnnMaybeG a e) = identLine i ++ show (a ^. sourceInfo) ++ " <?>" ++ maybe "" (\e -> treeDebug' (i + 1) e) e - + -- Modules instance (SourceInfo st, Domain dom) => TreeDebug UModule dom st instance (SourceInfo st, Domain dom) => TreeDebug UModuleHead dom st @@ -85,6 +85,7 @@ instance (SourceInfo st, Domain dom) => TreeDebug UBracket dom st instance (SourceInfo st, Domain dom) => TreeDebug UTopLevelPragma dom st instance (SourceInfo st, Domain dom) => TreeDebug URule dom st +instance (SourceInfo st, Domain dom) => TreeDebug URuleVar dom st instance (SourceInfo st, Domain dom) => TreeDebug UAnnotationSubject dom st instance (SourceInfo st, Domain dom) => TreeDebug UMinimalFormula dom st instance (SourceInfo st, Domain dom) => TreeDebug UExprPragma dom st @@ -113,6 +114,7 @@ instance (SourceInfo st, Domain dom) => TreeDebug ULanguageExtension dom st instance (SourceInfo st, Domain dom) => TreeDebug UMatchLhs dom st instance (SourceInfo st, Domain dom) => TreeDebug UInlinePragma dom st +instance (SourceInfo st, Domain dom) => TreeDebug USpecializePragma dom st -- ULiteral instance (SourceInfo st, Domain dom) => TreeDebug ULiteral dom st @@ -138,4 +140,4 @@ instance (SourceInfo st, Domain dom) => TreeDebug LineNumber dom st instance (SourceInfo st, Domain dom) => TreeDebug UPhaseControl dom st instance (SourceInfo st, Domain dom) => TreeDebug PhaseNumber dom st -instance (SourceInfo st, Domain dom) => TreeDebug PhaseInvert dom st \ No newline at end of file +instance (SourceInfo st, Domain dom) => TreeDebug PhaseInvert dom st diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-debug-0.5.0.0/haskell-tools-debug.cabal new/haskell-tools-debug-0.8.0.0/haskell-tools-debug.cabal --- old/haskell-tools-debug-0.5.0.0/haskell-tools-debug.cabal 2017-01-31 20:56:03.000000000 +0100 +++ new/haskell-tools-debug-0.8.0.0/haskell-tools-debug.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-debug -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Debugging Tools for Haskell-tools description: Debugging Tools for Haskell-tools homepage: https://github.com/haskell-tools/haskell-tools @@ -12,24 +12,25 @@ cabal-version: >=1.10 library - ghc-options: -O2 exposed-modules: Language.Haskell.Tools.Debug other-modules: Language.Haskell.Tools.DebugGhcAST , Language.Haskell.Tools.RangeDebug , Language.Haskell.Tools.RangeDebug.Instances build-depends: base >= 4.9 && < 4.10 + , filepath >= 1.4 && < 1.5 + , template-haskell >= 2.11 && < 2.12 , references >= 0.3 && < 0.4 , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-backend-ghc >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-backend-ghc >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 default-language: Haskell2010 - + executable ht-debug build-depends: base >= 4.9 && < 5.0 - , haskell-tools-debug >= 0.5 && < 0.6 + , haskell-tools-debug >= 0.8 && < 0.9 hs-source-dirs: exe main-is: Main.hs - default-language: Haskell2010 \ No newline at end of file + default-language: Haskell2010

1 0

commit ghc-haskell-tools-daemon for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-daemon for openSUSE:Factory checked in at 2017-08-31 20:55:58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-daemon (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-daemon.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-daemon" Thu Aug 31 20:55:58 2017 rev:2 rq:513371 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-daemon/ghc-haskell-tools-daemon.changes 2017-04-12 18:06:44.546333345 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-daemon.new/ghc-haskell-tools-daemon.changes 2017-08-31 20:55:58.975467845 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:15 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-daemon-0.5.0.0.tar.gz New: ---- haskell-tools-daemon-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-daemon.spec ++++++ --- /var/tmp/diff_new_pack.hgiBmJ/_old 2017-08-31 20:56:00.067314437 +0200 +++ /var/tmp/diff_new_pack.hgiBmJ/_new 2017-08-31 20:56:00.083312189 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-daemon %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Background process for Haskell-tools refactor that editors can connect to License: BSD-3-Clause @@ -28,6 +28,7 @@ Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: chrpath BuildRequires: ghc-Cabal-devel +BuildRequires: ghc-Diff-devel BuildRequires: ghc-aeson-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-containers-devel @@ -44,6 +45,7 @@ BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-split-devel +BuildRequires: ghc-strict-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %if %{with tests} BuildRequires: ghc-HUnit-devel ++++++ haskell-tools-daemon-0.5.0.0.tar.gz -> haskell-tools-daemon-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs --- old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs 2017-05-03 22:13:55.000000000 +0200 @@ -1,11 +1,13 @@ {-# LANGUAGE DeriveGeneric #-} module Language.Haskell.Tools.Refactor.Daemon.PackageDB where +import Control.Applicative (Applicative(..), (<$>), Alternative(..)) +import Control.Monad import Data.Aeson (FromJSON(..)) import Data.Char (isSpace) import Data.List import GHC.Generics (Generic(..)) -import System.Directory (withCurrentDirectory, doesFileExist, doesDirectoryExist) +import System.Directory import System.FilePath (FilePath, (</>)) import System.Process (readProcessWithExitCode) @@ -18,9 +20,6 @@ instance FromJSON PackageDB -packageDBLocs :: PackageDB -> [FilePath] -> IO [FilePath] -packageDBLocs pack = fmap concat . mapM (packageDBLoc pack) - packageDBLoc :: PackageDB -> FilePath -> IO [FilePath] packageDBLoc AutoDB path = (++) <$> packageDBLoc StackDB path <*> packageDBLoc CabalSandboxDB path packageDBLoc DefaultDB _ = return [] @@ -32,14 +31,43 @@ else return "" return $ map (drop (length "package-db: ")) $ filter ("package-db: " `isPrefixOf`) $ lines config packageDBLoc StackDB path = withCurrentDirectory path $ do - (_, snapshotDB, snapshotDBErrs) <- readProcessWithExitCode "stack" ["path", "--snapshot-pkg-db"] "" - (_, localDB, localDBErrs) <- readProcessWithExitCode "stack" ["path", "--local-pkg-db"] "" + (_, snapshotDB, snapshotDBErrs) <- readProcessWithExitCode "stack" ["path", "--allow-different-user", "--snapshot-pkg-db"] "" + (_, localDB, localDBErrs) <- readProcessWithExitCode "stack" ["path", "--allow-different-user", "--local-pkg-db"] "" return $ [trim localDB | null localDBErrs] ++ [trim snapshotDB | null snapshotDBErrs] packageDBLoc (ExplicitDB dir) path = do hasDir <- doesDirectoryExist (path </> dir) if hasDir then return [path </> dir] else return [] +-- | Gets the (probable) location of autogen folder depending on which type of +-- build we are using. +detectAutogen :: FilePath -> PackageDB -> IO (Maybe FilePath) +detectAutogen root AutoDB = do + defDB <- detectAutogen root DefaultDB + sandboxDB <- detectAutogen root CabalSandboxDB + stackDB <- detectAutogen root StackDB + return $ choose [ defDB, sandboxDB, stackDB ] +detectAutogen root DefaultDB = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root (ExplicitDB _) = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root CabalSandboxDB = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root StackDB = do + distExists <- doesDirectoryExist (root </> ".stack-work" </> "dist") + existing <- if distExists then (do + contents <- listDirectory (root </> ".stack-work" </> "dist") + let dirs = map ((root </> ".stack-work" </> "dist") </>) contents + subDirs <- mapM (\d -> map (d </>) <$> listDirectory d) dirs + mapM (ifExists . (</> "build" </> "autogen")) (dirs ++ concat subDirs)) else return [] + return (choose existing) + + trim :: String -> String trim = f . f - where f = reverse . dropWhile isSpace \ No newline at end of file + where f = reverse . dropWhile isSpace + +choose :: Alternative f => [f a] -> f a +choose = foldl (<|>) empty + +ifExists :: FilePath -> IO (Maybe FilePath) +ifExists fp = do exists <- doesDirectoryExist fp + if exists then return (Just fp) + else return Nothing diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs --- old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs 2017-06-07 10:55:20.000000000 +0200 @@ -4,12 +4,14 @@ import Control.Reference import Language.Haskell.Tools.Refactor.Daemon.PackageDB +import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Session -data DaemonSessionState +data DaemonSessionState = DaemonSessionState { _refactorSession :: RefactorSessionState , _packageDB :: PackageDB , _packageDBSet :: Bool + , _packageDBLocs :: [FilePath] , _exiting :: Bool } @@ -17,4 +19,4 @@ instance IsRefactSessionState DaemonSessionState where refSessMCs = refactorSession & refSessMCs - initSession = DaemonSessionState initSession AutoDB False False \ No newline at end of file + initSession = DaemonSessionState initSession AutoDB False [] False diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon.hs new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon.hs --- old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon.hs 2017-06-17 11:26:16.000000000 +0200 @@ -1,9 +1,11 @@ {-# LANGUAGE ScopedTypeVariables - , OverloadedStrings + , OverloadedStrings , DeriveGeneric , LambdaCase , TemplateHaskell , FlexibleContexts + , MultiWayIf + , TypeApplications #-} module Language.Haskell.Tools.Refactor.Daemon where @@ -11,13 +13,16 @@ import Control.Concurrent.MVar import Control.Exception import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Control.Reference import qualified Data.Aeson as A ((.=)) import Data.Aeson hiding ((.=)) +import Data.Algorithm.Diff +import qualified Data.ByteString.Char8 as StrictBS import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (unpack) import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Either import Data.IORef import Data.List hiding (insert) import qualified Data.Map as Map @@ -29,6 +34,8 @@ import System.Directory import System.Environment import System.IO +import System.IO.Strict as StrictIO (hGetContents) +import Data.Version import Bag import DynFlags @@ -50,10 +57,7 @@ import Language.Haskell.Tools.Refactor.Prepare import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Session - -import Debug.Trace - --- TODO: handle boot files +import Paths_haskell_tools_daemon runDaemonCLI :: IO () runDaemonCLI = getArgs >>= runDaemon @@ -62,15 +66,14 @@ runDaemon args = withSocketsDo $ do let finalArgs = args ++ drop (length args) defaultArgs isSilent = read (finalArgs !! 1) + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering when (not isSilent) $ putStrLn $ "Starting Haskell Tools daemon" - addrinfos <- getAddrInfo - (Just (defaultHints {addrFlags = [AI_PASSIVE]})) - Nothing (Just (finalArgs !! 0)) - let serveraddr = head addrinfos - sock <- socket (addrFamily serveraddr) Stream defaultProtocol + sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 - bind sock (addrAddress serveraddr) - listen sock 1 + when (not isSilent) $ putStrLn $ "Listening on port " ++ finalArgs !! 0 + bind sock (SockAddrInet (read (finalArgs !! 0)) iNADDR_ANY) + listen sock 4 clientLoop isSilent sock defaultArgs :: [String] @@ -115,58 +118,41 @@ -- | This function does the real job of acting upon client messages in a stateful environment of a client updateClient :: (ResponseMsg -> IO ()) -> ClientMessage -> StateT DaemonSessionState Ghc Bool +updateClient resp (Handshake _) = liftIO (resp $ HandshakeResponse $ versionBranch version) >> return True updateClient resp KeepAlive = liftIO (resp KeepAliveResponse) >> return True updateClient resp Disconnect = liftIO (resp Disconnected) >> return False -updateClient _ (SetPackageDB pkgDB) = modify (packageDB .= pkgDB) >> return True +updateClient _ (SetPackageDB pkgDB) = modify (packageDB .= pkgDB) >> return True updateClient resp (AddPackages packagePathes) = do - existingMCs <- gets (^. refSessMCs) - let existing = map ms_mod $ (existingMCs ^? traversal & filtered isTheAdded & mcModules & traversal & modRecMS) - needToReload <- (filter (\ms -> not $ ms_mod ms `elem` existing)) - <$> getReachableModules (\ms -> ms_mod ms `elem` existing) - modify $ refSessMCs .- filter (not . isTheAdded) -- remove the added package from the database - forM_ existing $ \mn -> removeTarget (TargetModule (GHC.moduleName mn)) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) }) - initializePackageDBIfNeeded - res <- loadPackagesFrom (return . getModSumOrig) packagePathes - case res of - Right (modules, ignoredMods) -> do - mapM_ (reloadModule (\_ -> return ())) needToReload -- don't report consequent reloads (not expected) - liftIO $ resp - $ if not (null ignoredMods) - then ErrorMessage - $ "The following modules are ignored: " - ++ concat (intersperse ", " ignoredMods) - ++ ". Multiple modules with the same qualified name are not supported." - else LoadedModules modules - Left err -> liftIO $ resp $ either ErrorMessage CompilationProblem (getProblems err) + addPackages resp packagePathes return True - where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes - initializePackageDBIfNeeded = do - pkgDBAlreadySet <- gets (^. packageDBSet) - when (not pkgDBAlreadySet) $ do - pkgDB <- gets (^. packageDB) - pkgDBLocs <- liftIO $ packageDBLocs pkgDB packagePathes - usePackageDB pkgDBLocs - modify (packageDBSet .= True) - updateClient _ (RemovePackages packagePathes) = do mcs <- gets (^. refSessMCs) - let existing = map ms_mod (mcs ^? traversal & filtered isRemoved & mcModules & traversal & modRecMS) - lift $ forM_ existing (\modName -> removeTarget (TargetModule (GHC.moduleName modName))) + let existingFiles = concatMap @[] (map (^. sfkFileName) . Map.keys) (mcs ^? traversal & filtered isRemoved & mcModules) + lift $ forM_ existingFiles (\fs -> removeTarget (TargetFile fs Nothing)) lift $ deregisterDirs (mcs ^? traversal & filtered isRemoved & mcSourceDirs & traversal) modify $ refSessMCs .- filter (not . isRemoved) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) }) + modifySession (\s -> s { hsc_mod_graph = filter ((`notElem` existingFiles) . getModSumOrig) (hsc_mod_graph s) }) + mcs <- gets (^. refSessMCs) + when (null mcs) $ modify (packageDBSet .= False) return True where isRemoved mc = (mc ^. mcRoot) `elem` packagePathes -updateClient resp (ReLoad changed removed) = - do removedMods <- gets (map ms_mod . filter ((`elem` removed) . getModSumOrig) . (^? refSessMCs & traversal & mcModules & traversal & modRecMS)) - lift $ forM_ removedMods (\modName -> removeTarget (TargetModule (GHC.moduleName modName))) - modify $ refSessMCs & traversal & mcModules - .- Map.filter (\m -> maybe True (not . (`elem` removed) . getModSumOrig) (m ^? modRecMS)) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` removedMods) . ms_mod) (hsc_mod_graph s) }) - reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms])) +updateClient resp (ReLoad added changed removed) = + -- TODO: check for changed cabal files and reload their packages + do mcs <- gets (^. refSessMCs) + lift $ forM_ removed (\src -> removeTarget (TargetFile src Nothing)) + -- remove targets deleted + modify $ refSessMCs & traversal & mcModules + .- Map.filter (\m -> maybe True ((`notElem` removed) . getModSumOrig) (m ^? modRecMS)) + modifySession (\s -> s { hsc_mod_graph = filter (\mod -> getModSumOrig mod `notElem` removed) (hsc_mod_graph s) }) + -- reload changed modules + -- TODO: filter those that are in reloaded packages + reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)])) + (\mss -> resp (LoadingModules (map getModSumOrig mss))) (\ms -> getModSumOrig ms `elem` changed) + mcs <- gets (^. refSessMCs) + let mcsToReload = filter (\mc -> any ((mc ^. mcRoot) `isPrefixOf`) added && isNothing (moduleCollectionPkgId (mc ^. mcId))) mcs + addPackages resp (map (^. mcRoot) mcsToReload) -- reload packages containing added modules liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage CompilationProblem (getProblems errs)) Right _ -> return () return True @@ -174,51 +160,135 @@ updateClient _ Stop = modify (exiting .= True) >> return False updateClient resp (PerformRefactoring refact modPath selection args) = do - (Just actualMod, otherMods) <- getFileMods modPath - let cmd = analyzeCommand refact (selection:args) - res <- lift $ performCommand cmd actualMod otherMods - case res of - Left err -> liftIO $ resp $ ErrorMessage err - Right diff -> do changedMods <- catMaybes <$> applyChanges diff - liftIO $ resp $ ModulesChanged (map snd changedMods) - -- when a new module is added, we need to compile it with the correct package db - void $ reloadChanges (map ((^. sfkModuleName) . fst) changedMods) + (selectedMod, otherMods) <- getFileMods modPath + case selectedMod of + Just actualMod -> do + case analyzeCommand refact (selection:args) of + Right cmd -> do res <- lift $ performCommand cmd actualMod otherMods + case res of + Left err -> liftIO $ resp $ ErrorMessage err + Right diff -> do changedMods <- applyChanges diff + liftIO $ resp $ ModulesChanged (map (either id (\(_,_,ch) -> ch)) changedMods) + void $ reloadChanges (map ((^. sfkModuleName) . (\(key,_,_) -> key)) (rights changedMods)) + Left err -> liftIO $ resp $ ErrorMessage err + Nothing -> liftIO $ resp $ ErrorMessage $ "The following file is not loaded to Haskell-tools: " + ++ modPath ++ ". Please add the containing package." return True - where applyChanges changes = do - forM changes $ \case - ModuleCreated n m otherM -> do + + where applyChanges changes = do + forM changes $ \case + ModuleCreated n m otherM -> do mcs <- gets (^. refSessMCs) Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs)) let Just otherMS = otherMR ^? modRecMS Just mc = lookupModuleColl (otherM ^. sfkModuleName) mcs - modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcId) == (mc ^. mcId)) & mcModules - .- Map.insert (SourceFileKey NormalHs n) (ModuleNotLoaded False) otherSrcDir <- liftIO $ getSourceDir otherMS let loc = toFileName otherSrcDir n - liftIO $ withBinaryFile loc WriteMode (`hPutStr` prettyPrint m) - lift $ addTarget (Target (TargetModule (GHC.mkModuleName n)) True Nothing) - return $ Just (SourceFileKey NormalHs n, loc) + modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcId) == (mc ^. mcId)) & mcModules + .- Map.insert (SourceFileKey loc n) (ModuleNotLoaded False False) + liftIO $ withBinaryFile loc WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle (prettyPrint m) + lift $ addTarget (Target (TargetFile loc Nothing) True Nothing) + return $ Right (SourceFileKey loc n, loc, RemoveAdded loc) ContentChanged (n,m) -> do - Just (_, mr) <- gets (lookupModInSCs n . (^. refSessMCs)) - let Just ms = mr ^? modRecMS - liftIO $ withBinaryFile (getModSumOrig ms) WriteMode (`hPutStr` prettyPrint m) - return $ Just (n, getModSumOrig ms) + let newCont = prettyPrint m + file = n ^. sfkFileName + origCont <- liftIO $ withBinaryFile file ReadMode $ \handle -> do + hSetEncoding handle utf8 + StrictIO.hGetContents handle + let undo = createUndo 0 $ getGroupedDiff origCont newCont + origCont <- liftIO $ withBinaryFile file WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle newCont + return $ Right (n, file, UndoChanges file undo) ModuleRemoved mod -> do - Just (_,m) <- gets (lookupModInSCs (SourceFileKey NormalHs mod) . (^. refSessMCs)) + Just (_,m) <- gets (lookupModuleInSCs mod . (^. refSessMCs)) let modName = GHC.moduleName $ fromJust $ fmap semanticsModule (m ^? typedRecModule) <|> fmap semanticsModule (m ^? renamedRecModule) ms <- getModSummary modName - lift $ removeTarget (TargetModule modName) + let file = getModSumOrig ms + origCont <- liftIO (StrictBS.unpack <$> StrictBS.readFile file) + lift $ removeTarget (TargetFile file Nothing) modify $ (refSessMCs .- removeModule mod) - liftIO $ removeFile (getModSumOrig ms) - return Nothing - - reloadChanges changedMods - = do reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms])) + liftIO $ removeFile file + return $ Left $ RestoreRemoved file origCont + + reloadChanges changedMods + = do reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)])) + (\mss -> resp (LoadingModules (map getModSumOrig mss))) (\ms -> modSumName ms `elem` changedMods) liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage (ErrorMessage . ("The result of the refactoring contains errors: " ++) . show) (getProblems errs)) Right _ -> return () +addPackages :: (ResponseMsg -> IO ()) -> [FilePath] -> StateT DaemonSessionState Ghc () +addPackages resp [] = return () +addPackages resp packagePathes = do + nonExisting <- filterM ((return . not) <=< liftIO . doesDirectoryExist) packagePathes + if (not (null nonExisting)) + then liftIO $ resp $ ErrorMessage $ "The following packages are not found: " ++ concat (intersperse ", " nonExisting) + else do + -- clear existing removed packages + existingMCs <- gets (^. refSessMCs) + let existing = (existingMCs ^? traversal & filtered isTheAdded & mcModules & traversal & modRecMS) + existingModNames = map ms_mod existing + needToReload <- handleErrors $ (filter (\ms -> not $ ms_mod ms `elem` existingModNames)) + <$> getReachableModules (\_ -> return ()) (\ms -> ms_mod ms `elem` existingModNames) + modify $ refSessMCs .- filter (not . isTheAdded) -- remove the added package from the database + forM_ existing $ \ms -> removeTarget (TargetFile (getModSumOrig ms) Nothing) + modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existingModNames) . ms_mod) (hsc_mod_graph s) }) + -- load new modules + pkgDBok <- initializePackageDBIfNeeded + if pkgDBok then do + res <- loadPackagesFrom (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)]) >> return (getModSumOrig ms)) + (resp . LoadingModules . map getModSumOrig) (\st fp -> maybeToList <$> detectAutogen fp (st ^. packageDB)) packagePathes + case res of + Right modules -> do + mapM_ (reloadModule (\_ -> return ())) (either (const []) id needToReload) -- don't report consequent reloads (not expected) + Left err -> liftIO $ resp $ either ErrorMessage CompilationProblem (getProblems err) + else liftIO $ resp $ ErrorMessage $ "Attempted to load two packages with different package DB. " + ++ "Stack, cabal-sandbox and normal packages cannot be combined" + where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes + initializePackageDBIfNeeded = do + pkgDBAlreadySet <- gets (^. packageDBSet) + pkgDB <- gets (^. packageDB) + locs <- liftIO $ mapM (packageDBLoc pkgDB) packagePathes + case locs of + firstLoc:rest -> + if | not (all (== firstLoc) rest) + -> return False + | pkgDBAlreadySet -> do + pkgDBLocs <- gets (^. packageDBLocs) + return (pkgDBLocs == firstLoc) + | otherwise -> do + usePackageDB firstLoc + modify ((packageDBSet .= True) . (packageDBLocs .= firstLoc)) + return True + [] -> return True + + +data UndoRefactor = RemoveAdded { undoRemovePath :: FilePath } + | RestoreRemoved { undoRestorePath :: FilePath + , undoRestoreContents :: String + } + | UndoChanges { undoChangedPath :: FilePath + , undoDiff :: FileDiff + } + deriving (Show, Generic) + +instance ToJSON UndoRefactor + +type FileDiff = [(Int, Int, String)] + +createUndo :: Eq a => Int -> [Diff [a]] -> [(Int, Int, [a])] +createUndo i (Both str _ : rest) = createUndo (i + length str) rest +createUndo i (First rem : Second add : rest) + = (i, i + length add, rem) : createUndo (i + length add) rest +createUndo i (First rem : rest) = (i, i, rem) : createUndo i rest +createUndo i (Second add : rest) + = (i, i + length add, []) : createUndo (i + length add) rest +createUndo _ [] = [] + initGhcSession :: IO Session initGhcSession = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags >> getSession)) @@ -226,9 +296,9 @@ usePackageDB [] = return () usePackageDB pkgDbLocs = do dfs <- getSessionDynFlags - dfs' <- liftIO $ fmap fst $ initPackages + dfs' <- liftIO $ fmap fst $ initPackages $ dfs { extraPkgConfs = (map PkgConfFile pkgDbLocs ++) . extraPkgConfs dfs - , pkgDatabase = Nothing + , pkgDatabase = Nothing } void $ setSessionDynFlags dfs' @@ -238,6 +308,7 @@ data ClientMessage = KeepAlive + | Handshake { clientVersion :: [Int] } | SetPackageDB { pkgDB :: PackageDB } | AddPackages { addedPathes :: [FilePath] } | RemovePackages { removedPathes :: [FilePath] } @@ -248,19 +319,22 @@ } | Stop | Disconnect - | ReLoad { changedModules :: [FilePath] + | ReLoad { addedModules :: [FilePath] + , changedModules :: [FilePath] , removedModules :: [FilePath] } deriving (Show, Generic) -instance FromJSON ClientMessage +instance FromJSON ClientMessage data ResponseMsg = KeepAliveResponse + | HandshakeResponse { serverVersion :: [Int] } | ErrorMessage { errorMsg :: String } | CompilationProblem { errorMarkers :: [(SrcSpan, String)] } - | ModulesChanged { moduleChanges :: [FilePath] } - | LoadedModules { loadedModules :: [FilePath] } + | ModulesChanged { undoChanges :: [UndoRefactor] } + | LoadedModules { loadedModules :: [(FilePath, String)] } + | LoadingModules { modulesToLoad :: [FilePath] } | Disconnected deriving (Show, Generic) @@ -268,9 +342,9 @@ instance ToJSON SrcSpan where toJSON (RealSrcSpan sp) = object [ "file" A..= unpackFS (srcSpanFile sp) - , "startRow" A..= srcLocLine (realSrcSpanStart sp) - , "startCol" A..= srcLocCol (realSrcSpanStart sp) - , "endRow" A..= srcLocLine (realSrcSpanEnd sp) + , "startRow" A..= srcLocLine (realSrcSpanStart sp) + , "startCol" A..= srcLocCol (realSrcSpanStart sp) + , "endRow" A..= srcLocLine (realSrcSpanEnd sp) , "endCol" A..= srcLocCol (realSrcSpanEnd sp) ] toJSON _ = Null diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/A.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/A.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/A.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/A.hs 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,5 @@ +module A where + +import B + +a = b \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/B.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/B.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/B.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/B.hs 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,3 @@ +module B where + +b = () \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/some-test-package.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/some-test-package.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/some-test-package.cabal 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,19 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 +extra-src-files: B.hs + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/UseGroups.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/UseGroups.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/UseGroups.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/UseGroups.hs 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,7 @@ +module UseGroups where + +import Data.Group +import Data.Monoid + +x :: Sum Int +x = 3 `pow` 5 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,30 @@ +Copyright (c) 2013, Nathan "Taneb" van Doorn + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nathan "Taneb" van Doorn nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal 2017-04-01 13:42:31.000000000 +0200 @@ -0,0 +1,19 @@ +name: groups +version: 0.4.0.0 +synopsis: Haskell 98 groups +description: + Haskell 98 groups. A group is a monoid with invertibility. +license: BSD3 +license-file: LICENSE +author: Nathan "Taneb" van Doorn +maintainer: nvd1234(a)gmail.com +copyright: Copyright (C) 2013 Nathan van Doorn +category: Algebra, Data, Math +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Data.Group + -- other-modules: + build-depends: base <5 + hs-source-dirs: src diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,92 @@ +module Data.Group where + +import Data.Monoid + +-- |A 'Group' is a 'Monoid' plus a function, 'invert', such that: +-- +-- @a \<> invert a == mempty@ +-- +-- @invert a \<> a == mempty@ +class Monoid m => Group m where + invert :: m -> m + -- |@'pow' a n == a \<> a \<> ... \<> a @ + -- + -- @ (n lots of a) @ + -- + -- If n is negative, the result is inverted. + pow :: Integral x => m -> x -> m + pow x0 n0 = case compare n0 0 of + LT -> invert . f x0 $ negate n0 + EQ -> mempty + GT -> f x0 n0 + where + f x n + | even n = f (x `mappend` x) (n `quot` 2) + | n == 1 = x + | otherwise = g (x `mappend` x) ((n - 1) `quot` 2) x + g x n c + | even n = g (x `mappend` x) (n `quot` 2) c + | n == 1 = x `mappend` c + | otherwise = g (x `mappend` x) ((n - 1) `quot` 2) (x `mappend` c) + +instance Group () where + invert () = () + pow () _ = () + +instance Num a => Group (Sum a) where + invert = Sum . negate . getSum + {-# INLINE invert #-} + pow (Sum a) b = Sum (a * fromIntegral b) + +instance Fractional a => Group (Product a) where + invert = Product . recip . getProduct + {-# INLINE invert #-} + pow (Product a) b = Product (a ^^ b) + +instance Group a => Group (Dual a) where + invert = Dual . invert . getDual + {-# INLINE invert #-} + pow (Dual a) n = Dual (pow a n) + +instance Group b => Group (a -> b) where + invert f = invert . f + pow f n e = pow (f e) n + +instance (Group a, Group b) => Group (a, b) where + invert (a, b) = (invert a, invert b) + pow (a, b) n = (pow a n, pow b n) + +instance (Group a, Group b, Group c) => Group (a, b, c) where + invert (a, b, c) = (invert a, invert b, invert c) + pow (a, b, c) n = (pow a n, pow b n, pow c n) + +instance (Group a, Group b, Group c, Group d) => Group (a, b, c, d) where + invert (a, b, c, d) = (invert a, invert b, invert c, invert d) + pow (a, b, c, d) n = (pow a n, pow b n, pow c n, pow d n) + +instance (Group a, Group b, Group c, Group d, Group e) => Group (a, b, c, d, e) where + invert (a, b, c, d, e) = (invert a, invert b, invert c, invert d, invert e) + pow (a, b, c, d, e) n = (pow a n, pow b n, pow c n, pow d n, pow e n) + +-- |An 'Abelian' group is a 'Group' that follows the rule: +-- +-- @a \<> b == b \<> a@ +class Group g => Abelian g + +instance Abelian () + +instance Num a => Abelian (Sum a) + +instance Fractional a => Abelian (Product a) + +instance Abelian a => Abelian (Dual a) + +instance Abelian b => Abelian (a -> b) + +instance (Abelian a, Abelian b) => Abelian (a, b) + +instance (Abelian a, Abelian b, Abelian c) => Abelian (a, b, c) + +instance (Abelian a, Abelian b, Abelian c, Abelian d) => Abelian (a, b, c, d) + +instance (Abelian a, Abelian b, Abelian c, Abelian d, Abelian e) => Abelian (a, b, c, d, e) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/some-test-package.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/some-test-package.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/some-test-package.cabal 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,18 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: UseGroups + build-depends: base + , groups + default-language: Haskell2010 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package1/package1.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package1/package1.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package1/package1.cabal 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package1/package1.cabal 2017-05-03 22:13:55.000000000 +0200 @@ -1,7 +1,7 @@ name: package1 version: 1.2.3.4 synopsis: A package just for testing Haskell-tools support. Don't install it. -description: +description: homepage: https://github.com/nboldi/haskell-tools license: BSD3 @@ -14,5 +14,5 @@ library exposed-modules: A - build-depends: base + build-depends: base, template-haskell default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package2/package2.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package2/package2.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package2/package2.cabal 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package2/package2.cabal 2017-05-03 22:13:55.000000000 +0200 @@ -1,7 +1,7 @@ name: package2 version: 1.2.3.4 synopsis: A package just for testing Haskell-tools support. Don't install it. -description: +description: homepage: https://github.com/nboldi/haskell-tools license: BSD3 @@ -14,5 +14,5 @@ library exposed-modules: B - build-depends: base, package1 + build-depends: base, package1, template-haskell default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Main.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Main.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Main.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Main.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello World" \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Unused.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Unused.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Unused.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Unused.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1 @@ +Not a valid haskell program diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/some-test-package.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/some-test-package.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/some-test-package.cabal 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,19 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + other-modules: Unused diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/haskell-tools-daemon.cabal new/haskell-tools-daemon-0.8.0.0/haskell-tools-daemon.cabal --- old/haskell-tools-daemon-0.5.0.0/haskell-tools-daemon.cabal 2017-01-31 20:56:31.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/haskell-tools-daemon.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-daemon -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Background process for Haskell-tools refactor that editors can connect to. description: Background process for Haskell-tools refactor that editors can connect to. homepage: https://github.com/haskell-tools/haskell-tools @@ -50,13 +50,24 @@ , examples/Project/load-error/*.hs , examples/Project/source-error/*.hs , examples/Project/empty/*.hs + , examples/Project/additional-files/*.hs + , examples/Project/additional-files/*.cabal + , examples/Project/cabal-sandbox/*.hs + , examples/Project/cabal-sandbox/*.cabal + , examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE + , examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs + , examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal + , examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs + , examples/Project/unused-mod/*.hs + , examples/Project/unused-mod/*.cabal + library - ghc-options: -O2 build-depends: base >= 4.9 && < 5.0 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 1.0 , filepath >= 1.4 && < 2.0 + , strict >= 0.3 && < 0.4 , containers >= 0.5 && < 0.6 , mtl >= 2.2 && < 2.3 , split >= 0.2 && < 1.0 @@ -66,30 +77,32 @@ , ghc-paths >= 0.1 && < 0.2 , references >= 0.3.2 && < 1.0 , network >= 2.6 && < 3.0 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 + , Diff >= 0.3 && < 0.4 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 exposed-modules: Language.Haskell.Tools.Refactor.Daemon , Language.Haskell.Tools.Refactor.Daemon.State , Language.Haskell.Tools.Refactor.Daemon.PackageDB + , Paths_haskell_tools_daemon default-language: Haskell2010 executable ht-daemon - ghc-options: -O2 + ghc-options: -rtsopts build-depends: base >= 4.9 && < 5.0 - , haskell-tools-daemon >= 0.5 && < 0.6 + , haskell-tools-daemon >= 0.8 && < 0.9 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 test-suite haskell-tools-daemon-tests type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2.5g -O2 + ghc-options: -with-rtsopts=-M2.5g hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: base >= 4.9 && < 4.10 - , HUnit >= 1.5 && < 1.6 + , HUnit >= 1.5 && < 1.7 , ghc >= 8.0 && < 8.1 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 @@ -98,6 +111,6 @@ , filepath >= 1.4 && < 2.0 , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 - , aeson >= 1.0 && < 1.2 - , haskell-tools-daemon >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , aeson >= 1.0 && < 1.3 + , haskell-tools-daemon >= 0.8 && < 0.9 + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/test/Main.hs new/haskell-tools-daemon-0.8.0.0/test/Main.hs --- old/haskell-tools-daemon-0.5.0.0/test/Main.hs 2017-01-31 20:34:13.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/test/Main.hs 2017-06-07 10:55:20.000000000 +0200 @@ -17,6 +17,7 @@ import Network.Socket.ByteString.Lazy as Sock import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.List as List +import Data.List (sort) import Data.Aeson import Data.Maybe import System.IO @@ -32,37 +33,38 @@ main :: IO () main = do unsetEnv "GHC_PACKAGE_PATH" - portCounter <- newMVar pORT_NUM_START + portCounter <- newMVar pORT_NUM_START tr <- canonicalizePath testRoot - isStackRun <- isJust <$> lookupEnv "STACK_EXE" - defaultMain (allTests isStackRun tr portCounter) + hasStack <- isJust <$> findExecutable "stack" + hasCabal <- isJust <$> findExecutable "cabal" + defaultMain (allTests (hasStack && hasCabal) tr portCounter) allTests :: Bool -> FilePath -> MVar Int -> TestTree allTests isSource testRoot portCounter - = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) - $ testGroup "daemon-tests" - [ testGroup "simple-tests" - $ map (makeDaemonTest portCounter . (\(label, input, output) -> (Nothing, label, input, output))) simpleTests - , testGroup "loading-tests" - $ map (makeDaemonTest portCounter . (\(label, input, output) -> (Nothing, label, input, output))) loadingTests - , testGroup "refactor-tests" - $ map (makeDaemonTest portCounter . (\(label, dir, input, output) -> (Just (testRoot </> dir), label, input, output))) (refactorTests testRoot) - , testGroup "reload-tests" + = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 20)) + $ testGroup "daemon-tests" + [ testGroup "simple-tests" + $ map (makeDaemonTest portCounter) simpleTests + , testGroup "loading-tests" + $ map (makeDaemonTest portCounter) loadingTests + , testGroup "refactor-tests" + $ map (makeRefactorTest portCounter) (refactorTests testRoot) + , testGroup "reload-tests" $ map (makeReloadTest portCounter) reloadingTests - , testGroup "compilation-problem-tests" + , testGroup "compilation-problem-tests" $ map (makeCompProblemTest portCounter) compProblemTests -- if not a stack build, we cannot guarantee that stack is on the path , if isSource then testGroup "pkg-db-tests" $ map (makePkgDbTest portCounter) pkgDbTests else testCase "IGNORED pkg-db-tests" (return ()) -- cannot execute this when the source is not present - , if isSource then selfLoadingTest portCounter else testCase "IGNORED self-load" (return ()) + -- , if isSource then selfLoadingTest portCounter else testCase "IGNORED self-load" (return ()) ] testSuffix = "_test" simpleTests :: [(String, [ClientMessage], [ResponseMsg])] -simpleTests = +simpleTests = [ ( "empty-test", [], [] ) , ( "keep-alive", [KeepAlive], [KeepAliveResponse] ) ] @@ -71,199 +73,207 @@ loadingTests = [ ( "load-package" , [AddPackages [testRoot </> "has-cabal"]] - , [LoadedModules [testRoot </> "has-cabal" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "has-cabal" </> "A.hs"] + , LoadedModules [(testRoot </> "has-cabal" </> "A.hs", "A")]] ) , ( "no-cabal" , [AddPackages [testRoot </> "no-cabal"]] - , [LoadedModules [testRoot </> "no-cabal" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "no-cabal" </> "A.hs"] + , LoadedModules [(testRoot </> "no-cabal" </> "A.hs", "A")]] ) , ( "source-dir" , [AddPackages [testRoot </> "source-dir"]] - , [LoadedModules [testRoot </> "source-dir" </> "src" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "source-dir" </> "src" </> "A.hs"] + , LoadedModules [(testRoot </> "source-dir" </> "src" </> "A.hs", "A")]] ) , ( "source-dir-outside" , [AddPackages [testRoot </> "source-dir-outside"]] - , [LoadedModules [testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs"] + , LoadedModules [(testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs", "A")]] ) , ( "multi-packages" , [ AddPackages [ testRoot </> "multi-packages" </> "package1" , testRoot </> "multi-packages" </> "package2" ]] - , [ LoadedModules [ testRoot </> "multi-packages" </> "package2" </> "B.hs" - , testRoot </> "multi-packages" </> "package1" </> "A.hs"]] ) + , [ LoadingModules [ testRoot </> "multi-packages" </> "package2" </> "B.hs" + , testRoot </> "multi-packages" </> "package1" </> "A.hs" ] + , LoadedModules [ (testRoot </> "multi-packages" </> "package2" </> "B.hs", "B") ] + , LoadedModules [ (testRoot </> "multi-packages" </> "package1" </> "A.hs", "A") ] ] ) , ( "multi-packages-flags" , [ AddPackages [ testRoot </> "multi-packages-flags" </> "package1" , testRoot </> "multi-packages-flags" </> "package2" ]] - , [ LoadedModules [ testRoot </> "multi-packages-flags" </> "package2" </> "B.hs" - , testRoot </> "multi-packages-flags" </> "package1" </> "A.hs"]] ) + , [ LoadingModules [ testRoot </> "multi-packages-flags" </> "package2" </> "B.hs" + , testRoot </> "multi-packages-flags" </> "package1" </> "A.hs" ] + , LoadedModules [ (testRoot </> "multi-packages-flags" </> "package2" </> "B.hs", "B") ] + , LoadedModules [ (testRoot </> "multi-packages-flags" </> "package1" </> "A.hs", "A") ] ] ) , ( "multi-packages-dependent" , [ AddPackages [ testRoot </> "multi-packages-dependent" </> "package1" , testRoot </> "multi-packages-dependent" </> "package2" ]] - , [ LoadedModules [ testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs" - , testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs"]] ) + , [ LoadingModules [ testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs" + , testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs" ] + , LoadedModules [ (testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs", "A") ] + , LoadedModules [ (testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs", "B") ] ] ) , ( "has-th" , [AddPackages [testRoot </> "has-th"]] - , [LoadedModules [testRoot </> "has-th" </> "TH.hs", testRoot </> "has-th" </> "A.hs"]] ) + , [ LoadingModules [ testRoot </> "has-th" </> "TH.hs", testRoot </> "has-th" </> "A.hs" ] + , LoadedModules [ (testRoot </> "has-th" </> "TH.hs", "TH") ] + , LoadedModules [ (testRoot </> "has-th" </> "A.hs", "A") ] ] ) , ( "th-added-later" , [ AddPackages [testRoot </> "th-added-later" </> "package1"] , AddPackages [testRoot </> "th-added-later" </> "package2"] ] - , [ LoadedModules [testRoot </> "th-added-later" </> "package1" </> "A.hs"] - , LoadedModules [testRoot </> "th-added-later" </> "package2" </> "B.hs"]] ) + , [ LoadingModules [ testRoot </> "th-added-later" </> "package1" </> "A.hs" ] + , LoadedModules [(testRoot </> "th-added-later" </> "package1" </> "A.hs", "A")] + , LoadingModules [ testRoot </> "th-added-later" </> "package2" </> "B.hs" ] + , LoadedModules [(testRoot </> "th-added-later" </> "package2" </> "B.hs", "B")] ] ) + , ( "unused-module" + , [ AddPackages [testRoot </> "unused-mod"] ] + , [ LoadingModules [ testRoot </> "unused-mod" </> "Main.hs" ] + , LoadedModules [ (testRoot </> "unused-mod" </> "Main.hs", "Main") ] ] ) ] compProblemTests :: [(String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool)] -compProblemTests = +compProblemTests = [ ( "load-error" - , [ Right $ AddPackages [testRoot </> "load-error"] ] - , \case [CompilationProblem {}] -> True; _ -> False) + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "load-error"] ] + , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) , ( "source-error" - , [ Right $ AddPackages [testRoot </> "source-error"] ] - , \case [CompilationProblem {}] -> True; _ -> False) + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "source-error"] ] + , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) , ( "reload-error" - , [ Right $ AddPackages [testRoot </> "empty"] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "empty"] , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\nimport No.Such.Module" - , Right $ ReLoad [testRoot </> "empty" </> "A.hs"] [] + , Right $ ReLoad [] [testRoot </> "empty" </> "A.hs"] [] , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"] - , \case [LoadedModules {}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules {}, LoadedModules {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) , ( "reload-source-error" - , [ Right $ AddPackages [testRoot </> "empty"] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "empty"] , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\naa = 3 + ()" - , Right $ ReLoad [testRoot </> "empty" </> "A.hs"] [] + , Right $ ReLoad [] [testRoot </> "empty" </> "A.hs"] [] , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"] - , \case [LoadedModules {}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules {}, LoadedModules {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) + , ( "no-such-file" + , [ Right $ PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] ] + , \case [ ErrorMessage _ ] -> True; _ -> False ) + , ( "additional-files" + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "additional-files"] ] + , \case [ LoadingModules {}, ErrorMessage _ ] -> True; _ -> False ) ] sourceRoot = ".." </> ".." </> "src" selfLoadingTest :: MVar Int -> TestTree -selfLoadingTest port = localOption (mkTimeout ({- 5 min -} 1000 * 1000 * 60 * 5)) $ testCase "self-load" $ do +selfLoadingTest port = localOption (mkTimeout ({- 5 min -} 1000 * 1000 * 60 * 5)) $ testCase "self-load" $ do actual <- communicateWithDaemon port - [ Right $ AddPackages (map (sourceRoot </>) ["ast", "backend-ghc", "prettyprint", "rewrite", "refactor", "daemon"]) ] - assertBool ("The expected result is a nonempty response message list that does not contain errors. Actual result: " ++ show actual) + [ Right $ AddPackages (map (sourceRoot </>) ["ast", "backend-ghc", "prettyprint", "rewrite", "refactor"]) ] + assertBool ("The expected result is a nonempty response message list that does not contain errors. Actual result: " ++ show actual) (not (null actual) && all (\case ErrorMessage {} -> False; _ -> True) actual) -refactorTests :: FilePath -> [(String, FilePath, [ClientMessage], [ResponseMsg])] +refactorTests :: FilePath -> [(String, FilePath, [ClientMessage], [ResponseMsg] -> Bool)] refactorTests testRoot = - [ ( "simple-refactor", "simple-refactor" + [ ( "simple-refactor", testRoot </> "simple-refactor" , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] ] - , [ LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - , ModulesChanged [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - ] ) - , ( "hs-boots", "hs-boots" + , \case [ LoadingModules{}, LoadedModules [ (aPath, _) ], ModulesChanged _, LoadingModules{}, LoadedModules [ (aPath', _) ]] + -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" && aPath == aPath'; _ -> False ) + , ( "hs-boots", testRoot </> "hs-boots" , [ AddPackages [ testRoot </> "hs-boots" ++ testSuffix ] , PerformRefactoring "RenameDefinition" (testRoot </> "hs-boots" ++ testSuffix </> "A.hs") "5:1-5:2" ["aa"] ] - , [ LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs-boot", testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" - , testRoot </> "hs-boots" ++ testSuffix </> "A.hs", testRoot </> "hs-boots" ++ testSuffix </> "B.hs" ] - , ModulesChanged [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs", testRoot </> "hs-boots" ++ testSuffix </> "B.hs" - , testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs-boot" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs" ] - ] ) - , ( "remove-module", "simple-refactor" + , \case [ LoadingModules{}, LoadedModules _, LoadedModules _, LoadedModules _, LoadedModules _, ModulesChanged _ + , LoadingModules{}, LoadedModules [ (path1, _) ], LoadedModules [ (path2, _) ] + , LoadedModules [ (path3, _) ], LoadedModules [ (path4, _) ] + ] -> let allPathes = map ((testRoot </> "hs-boots" ++ testSuffix) </>) ["A.hs","B.hs","A.hs-boot","B.hs-boot"] + in sort [path1,path2,path3,path4] == sort allPathes + _ -> False ) + , ( "remove-module", testRoot </> "simple-refactor" , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "1:8-1:9" ["AA"] ] - , [ LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - , ModulesChanged [ testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" ] - , LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" ] - ] ) + , \case [ LoadingModules{},LoadedModules [ (aPath, _) ], ModulesChanged _, LoadingModules{},LoadedModules [ (aaPath, _) ]] + -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" + && aaPath == testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" + _ -> False ) ] -reloadingTests :: [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg])] +reloadingTests :: [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool)] reloadingTests = [ ( "reloading-module", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]] - , writeFile (testRoot </> "reloading" ++ testSuffix </> "C.hs") "module C where\nc = ()" - , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "C.hs"] [] - , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "2:1-2:2" ["d"] - ] - , [ LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" - , testRoot </> "reloading" ++ testSuffix </> "B.hs" - , testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - , ModulesChanged [ testRoot </> "reloading" ++ testSuffix </> "C.hs" - , testRoot </> "reloading" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - ] - ) + , writeFile (testRoot </> "reloading" ++ testSuffix </> "C.hs") "module C where\nc = ()" + , [ ReLoad [] [testRoot </> "reloading" ++ testSuffix </> "C.hs"] [] + , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "2:1-2:2" ["d"] + ] + , \case [ LoadingModules{}, LoadedModules [(pathC'',_)], LoadedModules [(pathB'',_)], LoadedModules [(pathA'',_)] + , LoadingModules{}, LoadedModules [(pathC,_)], LoadedModules [(pathB,_)], LoadedModules [(pathA,_)] + , ModulesChanged _, LoadingModules{},LoadedModules [(pathC',_)], LoadedModules [(pathB',_)], LoadedModules [(pathA',_)] + ] -> let allPathes = map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs","A.hs"] + in [pathC,pathB,pathA] == allPathes + && [pathC',pathB',pathA'] == allPathes + && [pathC'',pathB'',pathA''] == allPathes + _ -> False ) , ( "reloading-package", testRoot </> "changing-cabal" , [ AddPackages [ testRoot </> "changing-cabal" ++ testSuffix ]] - , appendFile (testRoot </> "changing-cabal" ++ testSuffix </> "some-test-package.cabal") ", B" + , appendFile (testRoot </> "changing-cabal" ++ testSuffix </> "some-test-package.cabal") ", B" , [ AddPackages [testRoot </> "changing-cabal" ++ testSuffix] - , PerformRefactoring "RenameDefinition" (testRoot </> "changing-cabal" ++ testSuffix </> "A.hs") "3:1-3:2" ["z"] - ] - , [ LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" - , testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ] - , ModulesChanged [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" - , testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ] + , PerformRefactoring "RenameDefinition" (testRoot </> "changing-cabal" ++ testSuffix </> "A.hs") "3:1-3:2" ["z"] ] - ) + , \case [ LoadingModules{}, LoadedModules [(pathA,_)], LoadingModules{}, LoadedModules [(pathA',_)] + , LoadedModules [(pathB',_)], ModulesChanged _ + , LoadingModules{}, LoadedModules [(pathA'',_)], LoadedModules [(pathB'',_)] + ] -> let [pA,pB] = map ((testRoot </> "changing-cabal" ++ testSuffix) </>) ["A.hs","B.hs"] + in pA == pathA && pA == pathA' && pA == pathA'' && pB == pathB' && pB == pathB'' + _ -> False ) + , ( "adding-module", testRoot </> "reloading", [AddPackages [ testRoot </> "reloading" ++ testSuffix ]] + , writeFile (testRoot </> "reloading" ++ testSuffix </> "D.hs") "module D where\nd = ()" + , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "D.hs"] [] [] ] + , \case [ LoadingModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}, LoadingModules {} + , LoadingModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}] -> True + _ -> False ) , ( "reloading-remove", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]] , do removeFile (testRoot </> "reloading" ++ testSuffix </> "A.hs") removeFile (testRoot </> "reloading" ++ testSuffix </> "B.hs") - , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "C.hs"] - [testRoot </> "reloading" ++ testSuffix </> "A.hs", testRoot </> "reloading" ++ testSuffix </> "B.hs"] - , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "3:1-3:2" ["d"] - ] - , [ LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" - , testRoot </> "reloading" ++ testSuffix </> "B.hs" - , testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , ModulesChanged [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - ] - ) + , [ ReLoad [] [testRoot </> "reloading" ++ testSuffix </> "C.hs"] + [testRoot </> "reloading" ++ testSuffix </> "A.hs", testRoot </> "reloading" ++ testSuffix </> "B.hs"] + , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "3:1-3:2" ["d"] + ] + , \case [ LoadingModules{}, LoadedModules [(pathC,_)], LoadedModules [(pathB,_)], LoadedModules [(pathA,_)] + , LoadingModules{}, LoadedModules [(pathC',_)], ModulesChanged _, LoadingModules{}, LoadedModules [(pathC'',_)] ] + -> let [pC,pB,pA] = map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs","A.hs"] + in pA == pathA && pB == pathB && pC == pathC && pC == pathC' && pC == pathC'' + _ -> False ) , ( "remove-package", testRoot </> "multi-packages-dependent" , [ AddPackages [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" , testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2" ]] , removeDirectoryRecursive (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2") - , [ RemovePackages [testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2"] - , PerformRefactoring "RenameDefinition" (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs") - "3:1-3:2" ["d"] - ] - , [ LoadedModules [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" - , testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2" </> "B.hs" ] - , ModulesChanged [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" ] - , LoadedModules [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" ] - ] - ) + , [ RemovePackages [testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2"] + , PerformRefactoring "RenameDefinition" (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs") + "3:1-3:2" ["d"] + ] + , \case [ LoadingModules{}, LoadedModules [(pathA',_)], LoadedModules [(pathB',_)], ModulesChanged _, LoadingModules{}, LoadedModules [(pathA,_)] ] + -> let [pA,pB] = map ((testRoot </> "multi-packages-dependent" ++ testSuffix) </>) [ "package1" </> "A.hs", "package2" </> "B.hs"] + in pA == pathA && pA == pathA' && pB == pathB' + _ -> False ) ] pkgDbTests :: [(String, IO (), [ClientMessage], [ResponseMsg])] -pkgDbTests - = [ {- ( "stack" - , withCurrentDirectory (testRoot </> "stack") initStack - , [SetPackageDB StackDB, AddPackages [testRoot </> "stack"]] - , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] ) - , -} ( "cabal-sandbox" +pkgDbTests + = [ ( "cabal-sandbox" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox , [SetPackageDB CabalSandboxDB, AddPackages [testRoot </> "cabal-sandbox"]] - , [LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]] ) + , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")]] ) , ( "cabal-sandbox-auto" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox , [SetPackageDB AutoDB, AddPackages [testRoot </> "cabal-sandbox"]] - , [LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]] ) - -- , ( "stack-auto" - -- , withCurrentDirectory (testRoot </> "stack") initStack - -- , [SetPackageDB AutoDB, AddPackages [testRoot </> "stack"]] - -- , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] ) + , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")]] ) , ( "pkg-db-reload" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox , [ SetPackageDB AutoDB , AddPackages [testRoot </> "cabal-sandbox"] - , ReLoad [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] []] - , [ LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] - , LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] ]) - ] + , ReLoad [] [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] []] + , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")] + , LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")] ]) + ] where initCabalSandbox = do sandboxExists <- doesDirectoryExist ".cabal-sandbox" when sandboxExists $ tryToExecute "cabal" ["sandbox", "delete"] @@ -277,48 +287,50 @@ execute :: String -> [String] -> IO () -execute cmd args +execute cmd args = do let command = (cmd ++ concat (map (" " ++) args)) (_, Just stdOut, Just stdErr, handle) <- createProcess ((shell command) { std_out = CreatePipe, std_err = CreatePipe }) exitCode <- waitForProcess handle - when (exitCode /= ExitSuccess) $ do + when (exitCode /= ExitSuccess) $ do output <- hGetContents stdOut errors <- hGetContents stdErr error ("Command exited with nonzero: " ++ command ++ " output:\n" ++ output ++ "\nerrors:\n" ++ errors) tryToExecute :: String -> [String] -> IO () -tryToExecute cmd args +tryToExecute cmd args = do let command = (cmd ++ concat (map (" " ++) args)) (_, _, _, handle) <- createProcess ((shell command) { std_out = NoStream, std_err = NoStream }) void $ waitForProcess handle -makeDaemonTest :: MVar Int -> (Maybe FilePath, String, [ClientMessage], [ResponseMsg]) -> TestTree -makeDaemonTest port (Nothing, label, input, expected) = testCase label $ do +makeDaemonTest :: MVar Int -> (String, [ClientMessage], [ResponseMsg]) -> TestTree +makeDaemonTest port (label, input, expected) = testCase label $ do actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input)) assertEqual "" expected actual -makeDaemonTest port (Just dir, label, input, expected) = testCase label $ do + +makeRefactorTest :: MVar Int -> (String, FilePath, [ClientMessage], [ResponseMsg] -> Bool) -> TestTree +makeRefactorTest port (label, dir, input, validator) = testCase label $ do exists <- doesDirectoryExist (dir ++ testSuffix) -- clear the target directory from possible earlier test runs when exists $ removeDirectoryRecursive (dir ++ testSuffix) copyDir dir (dir ++ testSuffix) actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input)) - assertEqual "" expected actual + assertBool ("The responses are not the expected: " ++ show actual) (validator actual) `finally` removeDirectoryRecursive (dir ++ testSuffix) -makeReloadTest :: MVar Int -> (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg]) -> TestTree -makeReloadTest port (label, dir, input1, io, input2, expected) = testCase label $ do +makeReloadTest :: MVar Int -> (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool) -> TestTree +makeReloadTest port (label, dir, input1, io, input2, validator) = testCase label $ do exists <- doesDirectoryExist (dir ++ testSuffix) -- clear the target directory from possible earlier test runs when exists $ removeDirectoryRecursive (dir ++ testSuffix) copyDir dir (dir ++ testSuffix) actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input1) ++ [Left io] ++ map Right input2) - assertEqual "" expected actual + assertBool ("The responses are not the expected: " ++ show actual) (validator actual) `finally` removeDirectoryRecursive (dir ++ testSuffix) makePkgDbTest :: MVar Int -> (String, IO (), [ClientMessage], [ResponseMsg]) -> TestTree -makePkgDbTest port (label, prepare, inputs, expected) - = localOption (mkTimeout ({- 30s -} 1000 * 1000 * 30)) - $ testCase label $ do +makePkgDbTest port (label, prepare, inputs, expected) + = localOption (mkTimeout ({- 30s -} 1000 * 1000 * 30)) + $ testCase label $ do actual <- communicateWithDaemon port ([Left prepare] ++ map Right inputs) assertEqual "" expected actual @@ -344,14 +356,14 @@ sendAll sock $ encode Stop close sock return (concat intermedRes ++ resps) - where waitToConnect sock addr + where waitToConnect sock addr = connect sock addr `catch` \(e :: SomeException) -> waitToConnect sock addr - retryConnect port = do portNum <- readMVar port + retryConnect port = do portNum <- readMVar port forkIO $ runDaemon [show portNum, "True"] return portNum `catch` \(e :: SomeException) -> do putStrLn ("exception caught: `" ++ show e ++ "` trying with a new port") - modifyMVar_ port (\i -> if i < pORT_NUM_END - then return (i+1) + modifyMVar_ port (\i -> if i < pORT_NUM_END + then return (i+1) else error "The port number reached the maximum") retryConnect port @@ -360,18 +372,20 @@ readSockResponsesUntil sock rsp bs = do resp <- recv sock 2048 let fullBS = bs `BS.append` resp - if BS.null resp + if BS.null resp then return [] else let splitted = BS.split '\n' fullBS recognized = catMaybes $ map decode splitted - in if rsp `elem` recognized - then return $ List.delete rsp recognized + in if rsp `elem` recognized + then return $ List.delete rsp recognized else readSockResponsesUntil sock rsp fullBS testRoot = "examples" </> "Project" +deriving instance Eq UndoRefactor deriving instance Eq ResponseMsg +instance FromJSON UndoRefactor instance FromJSON ResponseMsg instance ToJSON ClientMessage instance ToJSON PackageDB @@ -400,15 +414,15 @@ longestCommonPrefix = foldl1 commonPrefix instance FromJSON SrcSpan where - parseJSON (Object v) = mkSrcSpanReal <$> v .: "file" - <*> v .: "startRow" - <*> v .: "startCol" + parseJSON (Object v) = mkSrcSpanReal <$> v .: "file" + <*> v .: "startRow" + <*> v .: "startCol" <*> v .: "endRow" <*> v .: "endCol" parseJSON _ = fail "not an object" mkSrcSpanReal :: String -> Int -> Int -> Int -> Int -> SrcSpan -mkSrcSpanReal file startRow startCol endRow endCol +mkSrcSpanReal file startRow startCol endRow endCol = mkSrcSpan (mkSrcLoc (mkFastString file) startRow startCol) (mkSrcLoc (mkFastString file) endRow endCol)

1 0

commit ghc-haskell-tools-cli for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-cli for openSUSE:Factory checked in at 2017-08-31 20:55:56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-cli (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-cli.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-cli" Thu Aug 31 20:55:56 2017 rev:2 rq:513370 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-cli/ghc-haskell-tools-cli.changes 2017-04-12 18:06:43.930420432 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-cli.new/ghc-haskell-tools-cli.changes 2017-08-31 20:55:57.907617881 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:05:13 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-cli-0.5.0.0.tar.gz New: ---- haskell-tools-cli-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-cli.spec ++++++ --- /var/tmp/diff_new_pack.WvP5Dy/_old 2017-08-31 20:55:58.675509990 +0200 +++ /var/tmp/diff_new_pack.WvP5Dy/_new 2017-08-31 20:55:58.675509990 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-cli %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Command-line frontend for Haskell-tools Refact License: BSD-3-Clause @@ -41,6 +41,7 @@ BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-split-devel +BuildRequires: ghc-strict-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %if %{with tests} BuildRequires: ghc-bytestring-devel @@ -88,7 +89,6 @@ %defattr(-,root,root,-) %doc LICENSE %{_bindir}/ht-refact -%{_bindir}/ht-test-hackage %{_bindir}/ht-test-stackage %files devel -f %{name}-devel.files ++++++ haskell-tools-cli-0.5.0.0.tar.gz -> haskell-tools-cli-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/Language/Haskell/Tools/Refactor/CLI.hs new/haskell-tools-cli-0.8.0.0/Language/Haskell/Tools/Refactor/CLI.hs --- old/haskell-tools-cli-0.5.0.0/Language/Haskell/Tools/Refactor/CLI.hs 2017-01-31 20:47:43.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/Language/Haskell/Tools/Refactor/CLI.hs 2017-07-01 13:13:30.000000000 +0200 @@ -9,14 +9,17 @@ import Control.Applicative ((<|>)) import Control.Exception (displayException) -import Control.Monad.State +import Control.Monad.State.Strict import Control.Reference import Data.List import Data.List.Split import Data.Maybe +import Data.Char import System.Directory import System.Exit import System.IO +import System.FilePath +import Data.Version (showVersion) import DynFlags as GHC import ErrUtils @@ -27,14 +30,15 @@ import Packages import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor as HT import Language.Haskell.Tools.Refactor.GetModules import Language.Haskell.Tools.Refactor.Perform import Language.Haskell.Tools.Refactor.Session +import Paths_haskell_tools_cli (version) type CLIRefactorSession = StateT CLISessionState Ghc -data CLISessionState = +data CLISessionState = CLISessionState { _refactState :: RefactorSessionState , _actualMod :: Maybe SourceFileKey , _exiting :: Bool @@ -46,11 +50,13 @@ deriving instance Show PkgConfRef tryOut :: IO () -tryOut = void $ refactorSession stdin stdout +tryOut = void $ refactorSession stdin stdout [ "-dry-run", "-one-shot", "-module-name=Language.Haskell.Tools.AST", "-refactoring=OrganizeImports" , "src/ast", "src/backend-ghc", "src/prettyprint", "src/rewrite", "src/refactor"] refactorSession :: Handle -> Handle -> [String] -> IO Bool +refactorSession _ _ args | "-v" `elem` args = do putStrLn $ showVersion version + return True refactorSession input output args = runGhc (Just libdir) $ handleSourceError printSrcErrors $ flip evalStateT initSession $ do lift $ initGhcFlags @@ -61,8 +67,8 @@ else do initSuccess <- initializeSession output workingDirs htFlags when initSuccess $ runSession input output htFlags return initSuccess - - where printSrcErrors err = do dfs <- getSessionDynFlags + + where printSrcErrors err = do dfs <- getSessionDynFlags liftIO $ printBagOfErrors dfs (srcErrorMessages err) return False @@ -70,16 +76,10 @@ initializeSession output workingDirs flags = do liftIO $ hSetBuffering output NoBuffering liftIO $ hPutStrLn output "Compiling modules. This may take some time. Please wait." - res <- loadPackagesFrom (\ms -> liftIO $ hPutStrLn output ("Loaded module: " ++ modSumName ms)) workingDirs - case res of - Right (_, ignoredMods) -> do - when (not $ null ignoredMods) - $ liftIO $ hPutStrLn output - $ "The following modules are ignored: " - ++ concat (intersperse ", " $ ignoredMods) - ++ ". Multiple modules with the same qualified name are not supported." - - liftIO . hPutStrLn output $ if ("-one-shot" `elem` flags) + res <- loadPackagesFrom (\ms -> liftIO $ hPutStrLn output ("Loaded module: " ++ modSumName ms)) (const $ return ()) (\_ _ -> return []) workingDirs + case res of + Right _ -> do + liftIO . hPutStrLn output $ if ("-one-shot" `elem` flags) then "All modules loaded." else "All modules loaded. Use 'SelectModule module-name' to select a module." when ("-dry-run" `elem` flags) $ modify (dryMode .= True) @@ -91,7 +91,7 @@ runSession _ output flags | "-one-shot" `elem` flags = let modName = catMaybes $ map (\f -> case splitOn "=" f of ["-module-name", mod] -> Just mod; _ -> Nothing) flags refactoring = catMaybes $ map (\f -> case splitOn "=" f of ["-refactoring", ref] -> Just ref; _ -> Nothing) flags - in case (modName, refactoring) of + in case (modName, refactoring) of ([modName],[refactoring]) -> do performSessionCommand output (LoadModule modName) command <- readSessionCommand output (takeWhile (/='"') $ dropWhile (=='"') $ refactoring) @@ -102,13 +102,13 @@ runSession input output _ = runSessionLoop input output runSessionLoop :: Handle -> Handle -> CLIRefactorSession () - runSessionLoop input output = do + runSessionLoop input output = do actualMod <- gets (^. actualMod) liftIO $ hPutStr output (maybe "no-module-selected> " (\sfk -> (sfk ^. sfkModuleName) ++ "> ") actualMod) - cmd <- liftIO $ hGetLine input + cmd <- liftIO $ hGetLine input sessionComm <- readSessionCommand output cmd changedMods <- performSessionCommand output sessionComm - void $ reloadChangedModules (hPutStrLn output . ("Re-loaded module: " ++) . modSumName) + void $ reloadChangedModules (hPutStrLn output . ("Re-loaded module: " ++) . modSumName) (const $ return ()) (\ms -> keyFromMS ms `elem` changedMods) doExit <- gets (^. exiting) when (not doExit) (void (runSessionLoop input output)) @@ -116,7 +116,7 @@ usageMessage = "Usage: ht-refact [ht-flags, ghc-flags] package-pathes\n" ++ "ht-flags: -dry-run -one-shot -module-name=modulename -refactoring=\"refactoring\"" -data RefactorSessionCommand +data RefactorSessionCommand = LoadModule String | Skip | Exit @@ -124,27 +124,40 @@ deriving Show readSessionCommand :: Handle -> String -> CLIRefactorSession RefactorSessionCommand -readSessionCommand output cmd = case splitOn " " cmd of +readSessionCommand output cmd = case (splitOn " " cmd) of ["SelectModule", mod] -> return $ LoadModule mod - ["Exit"] -> return Exit - _ -> do actualMod <- gets (^. actualMod) - case actualMod of Just _ -> return $ RefactorCommand $ readCommand cmd - Nothing -> do liftIO $ hPutStrLn output "Set the actual module first" - return Skip + ["Exit"] -> return Exit + cm | head cm `elem` refactorCommands + -> do actualMod <- gets (^. actualMod) + case readCommand cmd of + Right cmd -> + case actualMod of Just _ -> return $ RefactorCommand cmd + Nothing -> do liftIO $ hPutStrLn output "Set the actual module first" + return Skip + Left err -> do liftIO $ hPutStrLn output err + return Skip + _ -> do liftIO $ hPutStrLn output $ "'" ++ cmd ++ "' is not a known command. Commands are: SelectModule, Exit, " + ++ intercalate ", " refactorCommands + return Skip performSessionCommand :: Handle -> RefactorSessionCommand -> CLIRefactorSession [SourceFileKey] -performSessionCommand output (LoadModule modName) = do - mod <- gets (lookupModInSCs (SourceFileKey NormalHs modName) . (^. refSessMCs)) - if isJust mod then modify $ actualMod .= fmap fst mod - else liftIO $ hPutStrLn output ("Cannot find module: " ++ modName) +performSessionCommand output (LoadModule modName) = do + files <- HT.findModule modName + mcs <- gets (^. refSessMCs) + case nub files of + [] -> liftIO $ hPutStrLn output ("Cannot find module: " ++ modName) + [fileName] -> do + mod <- gets (lookupModInSCs (SourceFileKey fileName modName) . (^. refSessMCs)) + modify $ actualMod .= fmap fst mod + _ -> liftIO $ hPutStrLn output ("Ambiguous module: " ++ modName ++ " found: " ++ show files ++ " " ++ show mcs) return [] performSessionCommand _ Skip = return [] performSessionCommand _ Exit = do modify $ exiting .= True return [] -performSessionCommand output (RefactorCommand cmd) +performSessionCommand output (RefactorCommand cmd) = do actMod <- gets (^. actualMod) (actualMod, otherMods) <- getMods actMod - res <- case actualMod of + res <- case actualMod of Just mod -> lift $ performCommand cmd mod otherMods -- WALKAROUND: support running refactors that need no module selected Nothing -> case otherMods of (hd:rest) -> lift $ performCommand cmd hd rest @@ -154,34 +167,40 @@ return [] Right resMods -> performChanges output inDryMode resMods - where performChanges output False resMods = - forM resMods $ \case - ModuleCreated n m otherM -> do + where performChanges :: HasModuleInfo dom => Handle -> Bool -> [RefactorChange dom] -> CLIRefactorSession [SourceFileKey] + performChanges output False resMods = + forM resMods $ \case + ModuleCreated n m otherM -> do Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs)) let Just otherMS = otherMR ^? modRecMS + otherSrcDir <- liftIO $ getSourceDir otherMS let loc = srcDirFromRoot otherSrcDir n - liftIO $ withBinaryFile loc WriteMode (`hPutStr` prettyPrint m) - return (SourceFileKey NormalHs n) + liftIO $ withBinaryFile loc WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle (prettyPrint m) + return (SourceFileKey n (sourceFileModule (loc `makeRelative` n))) ContentChanged (n,m) -> do - let modName = semanticsModule m - ms <- getModSummary modName (isBootModule $ m ^. semantics) - let file = fromJust $ ml_hs_file $ ms_location ms - liftIO $ withBinaryFile file WriteMode (`hPutStr` prettyPrint m) + let file = n ^. sfkFileName + liftIO $ withBinaryFile file WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle (prettyPrint m) return n ModuleRemoved mod -> do - Just (_,m) <- gets (lookupModInSCs (SourceFileKey NormalHs mod) . (^. refSessMCs)) + Just (_,m) <- gets (lookupSourceFileInSCs mod . (^. refSessMCs)) case ( fmap semanticsModule (m ^? typedRecModule) <|> fmap semanticsModule (m ^? renamedRecModule) - , fmap isBootModule (m ^? typedRecModule) <|> fmap isBootModule (m ^? renamedRecModule)) of + , fmap isBootModule (m ^? typedRecModule) <|> fmap isBootModule (m ^? renamedRecModule)) of (Just modName, Just isBoot) -> do ms <- getModSummary modName isBoot let file = fromJust $ ml_hs_file $ ms_location ms modify $ (refSessMCs .- removeModule mod) liftIO $ removeFile file + return (SourceFileKey file mod) _ -> do liftIO $ hPutStrLn output ("Module " ++ mod ++ " could not be removed.") - return (SourceFileKey NormalHs mod) - performChanges output True resMods = do - forM_ resMods (liftIO . \case + return (SourceFileKey "" mod) + + performChanges output True resMods = do + forM_ resMods (liftIO . \case ContentChanged (n,m) -> do hPutStrLn output $ "### Module changed: " ++ (n ^. sfkModuleName) ++ "\n### new content:\n" ++ prettyPrint m ModuleRemoved mod -> @@ -192,9 +211,8 @@ getModSummary name boot = do allMods <- lift getModuleGraph - return $ fromJust $ find (\ms -> ms_mod ms == name && (ms_hsc_src ms == HsSrcFile) /= boot) allMods + return $ fromJust $ find (\ms -> ms_mod ms == name && (ms_hsc_src ms == HsSrcFile) /= boot) allMods instance IsRefactSessionState CLISessionState where refSessMCs = refactState & _refSessMCs initSession = CLISessionState initSession Nothing False False - \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/cpp-opt/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/cpp-opt/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/cpp-opt/A.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/cpp-opt/A.hs 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} +module A where + +#ifndef MACRO +"The macro 'MACRO' defined in the cabal file is not applied." +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/cpp-opt/some-test-package.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/cpp-opt/some-test-package.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/cpp-opt/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/cpp-opt/some-test-package.cabal 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,19 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 + cpp-options: -DMACRO \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/illegal-extension/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/illegal-extension/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/illegal-extension/A.hs 2017-01-15 14:39:30.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/illegal-extension/A.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,2 +0,0 @@ -{-# LANGUAGE CPP #-} -module A where \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package1/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package1/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package1/A.hs 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package1/A.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,3 +0,0 @@ -module A where - -x = () \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package1/package1.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package1/package1.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package1/package1.cabal 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package1/package1.cabal 1970-01-01 01:00:00.000000000 +0100 @@ -1,18 +0,0 @@ -name: package1 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi(a)elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package2/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package2/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package2/A.hs 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package2/A.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1 +0,0 @@ -module A where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package2/package2.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package2/package2.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/multi-packages-same-module/package2/package2.cabal 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/multi-packages-same-module/package2/package2.cabal 1970-01-01 01:00:00.000000000 +0100 @@ -1,18 +0,0 @@ -name: package2 -version: 1.2.3.4 -synopsis: A package just for testing Haskell-tools support. Don't install it. -description: - -homepage: https://github.com/nboldi/haskell-tools -license: BSD3 -license-file: LICENSE -author: Boldizsar Nemeth -maintainer: nboldi(a)elte.hu -category: Language -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-main/Main.hs new/haskell-tools-cli-0.8.0.0/examples/Project/with-main/Main.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-main/Main.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-main/Main.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello World" \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-main/some-test-package.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/with-main/some-test-package.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-main/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-main/some-test-package.cabal 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,18 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-main-renamed/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/with-main-renamed/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-main-renamed/A.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-main-renamed/A.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello World" \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-main-renamed/some-test-package.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/with-main-renamed/some-test-package.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-main-renamed/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-main-renamed/some-test-package.cabal 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,18 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +executable foo + main-is: A.hs + build-depends: base + default-language: Haskell2010 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/A.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/A.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,5 @@ +module Main where + +import B + +main = putStrLn (b ++ " World") \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/B.hs new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/B.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/B.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/B.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,3 @@ +module B where + +b = "Hello" \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/Main.hs new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/Main.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/Main.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/Main.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello World" \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/some-test-package.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/some-test-package.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-multi-main/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-multi-main/some-test-package.cabal 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,24 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +executable foo + main-is: A.hs + build-depends: base + default-language: Haskell2010 + other-modules: B + +executable bar + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-other-executable/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/with-other-executable/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-other-executable/A.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-other-executable/A.hs 2017-06-08 14:14:30.000000000 +0200 @@ -0,0 +1,3 @@ +module A where + +main = putStrLn "Hello World" \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/with-other-executable/some-test-package.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/with-other-executable/some-test-package.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/with-other-executable/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/with-other-executable/some-test-package.cabal 2017-06-08 14:14:30.000000000 +0200 @@ -0,0 +1,19 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +executable foo + main-is: A.hs + build-depends: base + default-language: Haskell2010 + ghc-options: -main-is A.main diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/working-dir/some-test-package.cabal new/haskell-tools-cli-0.8.0.0/examples/Project/working-dir/some-test-package.cabal --- old/haskell-tools-cli-0.5.0.0/examples/Project/working-dir/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/working-dir/some-test-package.cabal 2017-06-17 11:26:16.000000000 +0200 @@ -0,0 +1,19 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi(a)elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + hs-source-dirs: src + build-depends: base, directory, filepath + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/examples/Project/working-dir/src/A.hs new/haskell-tools-cli-0.8.0.0/examples/Project/working-dir/src/A.hs --- old/haskell-tools-cli-0.5.0.0/examples/Project/working-dir/src/A.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/examples/Project/working-dir/src/A.hs 2017-06-17 11:26:16.000000000 +0200 @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module A where + +import Language.Haskell.TH +import System.FilePath + +$(location >>= \loc -> runIO (readFile (takeDirectory (takeDirectory (loc_filename loc)) </> "data.txt")) >> return []) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/haskell-tools-cli.cabal new/haskell-tools-cli-0.8.0.0/haskell-tools-cli.cabal --- old/haskell-tools-cli-0.5.0.0/haskell-tools-cli.cabal 2017-01-31 20:57:11.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/haskell-tools-cli.cabal 2017-07-01 13:09:12.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-cli -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Command-line frontend for Haskell-tools Refact description: Command-line frontend for Haskell-tools Refact. Not meant as a final product, only for demonstration purposes. homepage: https://github.com/haskell-tools/haskell-tools @@ -14,6 +14,8 @@ extra-source-files: examples/CppHs/Language/Preprocessor/*.hs , examples/CppHs/Language/Preprocessor/Cpphs/*.hs , bench-tests/*.txt + , examples/Project/cpp-opt/*.hs + , examples/Project/cpp-opt/*.cabal , examples/Project/has-cabal/*.hs , examples/Project/has-cabal/*.cabal , examples/Project/multi-packages/package1/*.hs @@ -24,21 +26,26 @@ , examples/Project/multi-packages-flags/package1/*.cabal , examples/Project/multi-packages-flags/package2/*.hs , examples/Project/multi-packages-flags/package2/*.cabal - , examples/Project/multi-packages-same-module/package1/*.hs - , examples/Project/multi-packages-same-module/package1/*.cabal - , examples/Project/multi-packages-same-module/package2/*.hs - , examples/Project/multi-packages-same-module/package2/*.cabal , examples/Project/no-cabal/*.hs - , examples/Project/illegal-extension/*.hs , examples/Project/reloading/*.hs , examples/Project/selection/*.hs , examples/Project/source-dir/*.cabal , examples/Project/source-dir/src/*.hs , examples/Project/source-dir-outside/*.cabal + , examples/Project/working-dir/src/*.hs + , examples/Project/working-dir/*.cabal + , examples/Project/working-dir/*.txt + , examples/Project/with-main/*.hs + , examples/Project/with-main/*.cabal + , examples/Project/with-main-renamed/*.hs + , examples/Project/with-main-renamed/*.cabal + , examples/Project/with-multi-main/*.hs + , examples/Project/with-multi-main/*.cabal + , examples/Project/with-other-executable/*.hs + , examples/Project/with-other-executable/*.cabal , examples/Project/src/*.hs library - ghc-options: -O2 build-depends: base >= 4.9 && < 4.10 , containers >= 0.5 && < 0.6 , mtl >= 2.2 && < 2.3 @@ -48,68 +55,60 @@ , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , references >= 0.3 && < 0.4 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 + , strict >= 0.3 && < 0.4 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 exposed-modules: Language.Haskell.Tools.Refactor.CLI + , Paths_haskell_tools_cli default-language: Haskell2010 executable ht-refact - ghc-options: -O2 -rtsopts + ghc-options: -rtsopts build-depends: base >= 4.9 && < 4.10 - , haskell-tools-cli >= 0.5 && < 0.6 + , haskell-tools-cli >= 0.8 && < 0.9 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 - -executable ht-test-hackage - build-depends: base >= 4.9 && < 4.10 - , directory >= 1.2 && < 1.4 - , process >= 1.4 && < 1.5 - , split >= 0.2 && < 0.3 - hs-source-dirs: test-hackage - main-is: Main.hs - default-language: Haskell2010 executable ht-test-stackage build-depends: base >= 4.9 && < 4.10 , directory >= 1.2 && < 1.4 , process >= 1.4 && < 1.5 , split >= 0.2 && < 0.3 + ghc-options: -threaded -with-rtsopts=-M4g hs-source-dirs: test-stackage main-is: Main.hs default-language: Haskell2010 test-suite haskell-tools-cli-tests type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2g -O2 + ghc-options: -with-rtsopts=-M2g hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: base >= 4.9 && < 4.10 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 - , haskell-tools-cli >= 0.5 && < 0.6 + , haskell-tools-cli >= 0.8 && < 0.9 , knob >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 default-language: Haskell2010 benchmark cli-benchmark type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2g -O2 + ghc-options: -with-rtsopts=-M2g build-depends: base >= 4.9 && < 4.10 - , haskell-tools-cli >= 0.5 && < 0.6 - , criterion >= 1.1 && < 1.2 + , haskell-tools-cli >= 0.8 && < 0.9 + , criterion >= 1.1 && < 1.3 , time >= 1.6 && < 1.7 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 , knob >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 , split >= 0.2 && < 0.3 hs-source-dirs: benchmark - main-is: Main.hs - - + main-is: Main.hs diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/test/Main.hs new/haskell-tools-cli-0.8.0.0/test/Main.hs --- old/haskell-tools-cli-0.5.0.0/test/Main.hs 2017-01-31 20:34:13.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/test/Main.hs 2017-06-17 11:26:16.000000000 +0200 @@ -23,76 +23,86 @@ allTests = map makeCliTest cliTests makeCliTest :: ([FilePath], [String], String, String) -> TestTree -makeCliTest (dirs, args, input, output) = let dir = joinPath $ longestCommonPrefix $ map splitDirectories dirs - testdirs = map (((dir ++ "_test") </>) . makeRelative dir) dirs - in testCase dir $ do - exists <- doesDirectoryExist (dir ++ "_test") - when exists $ removeDirectoryRecursive (dir ++ "_test") - copyDir dir (dir ++ "_test") - inKnob <- newKnob (pack input) - inHandle <- newFileHandle inKnob "<input>" ReadMode - outKnob <- newKnob (pack []) - outHandle <- newFileHandle outKnob "<output>" WriteMode - res <- refactorSession inHandle outHandle (args ++ testdirs) - actualOut <- Data.Knob.getContents outKnob - assertEqual "" (filter (/= '\r') output) (filter (/= '\r') $ unpack actualOut) - `finally` removeDirectoryRecursive (dir ++ "_test") +makeCliTest (dirs, args, input, output) + = let dir = joinPath $ longestCommonPrefix $ map splitDirectories dirs + testdirs = map (\d -> if d == dir then dir ++ "_test" else (dir ++ "_test" </> makeRelative dir d)) dirs + in testCase dir $ do + exists <- doesDirectoryExist (dir ++ "_test") + when exists $ removeDirectoryRecursive (dir ++ "_test") + copyDir dir (dir ++ "_test") + inKnob <- newKnob (pack input) + inHandle <- newFileHandle inKnob "<input>" ReadMode + outKnob <- newKnob (pack []) + outHandle <- newFileHandle outKnob "<output>" WriteMode + res <- refactorSession inHandle outHandle (args ++ testdirs) + actualOut <- Data.Knob.getContents outKnob + assertEqual "" (filter (/= '\r') output) (filter (/= '\r') $ unpack actualOut) + `finally` removeDirectoryRecursive (dir ++ "_test") cliTests :: [([FilePath], [String], String, String)] -cliTests - = [ ( [testRoot </> "Project" </> "source-dir"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] +cliTests + = [ ( [testRoot </> "Project" </> "cpp-opt"] + , ["-dry-run", "-one-shot", "-module-name=A"] + , "", oneShotPrefix ["A"] ++ "-module-name or -refactoring flag not specified correctly. Not doing any refactoring.\n") + , ( [testRoot </> "Project" </> "source-dir"] + , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") + , ( [testRoot </> "Project" </> "working-dir"] + , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"OrganizeImports\""] + , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\n{-# LANGUAGE TemplateHaskell #-}\nmodule A where\n\nimport Language.Haskell.TH\nimport System.FilePath\n\n$(location >>= \\loc -> runIO (readFile (takeDirectory (takeDirectory (loc_filename loc)) </> \"data.txt\")) >> return [])\n\n") , ( [testRoot </> "Project" </> "source-dir-outside"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] + , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") , ( [testRoot </> "Project" </> "no-cabal"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] + , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") , ( [testRoot </> "Project" </> "has-cabal"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] + , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1-3:1\""] , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nx :: ()\nx = ()\n") - , ( [testRoot </> "Project" </> "selection"], [] + , ( [testRoot </> "Project" </> "selection"], [] , "SelectModule C\nSelectModule B\nRenameDefinition 5:1-5:2 bb\nSelectModule C\nRenameDefinition 3:1-3:2 cc\nExit" - , prefixText ["C","B"] ++ "no-module-selected> C> B> " + , prefixText ["C","B"] ++ "no-module-selected> C> B> " ++ reloads ["B"] ++ "B> C> " ++ reloads ["C", "B"] ++ "C> " ) - , ( [testRoot </> "Project" </> "reloading"], [] + , ( [testRoot </> "Project" </> "reloading"], [] , "SelectModule C\nRenameDefinition 3:1-3:2 cc\nSelectModule B\nRenameDefinition 5:1-5:2 bb\nExit" - , prefixText ["C","B","A"] ++ "no-module-selected> C> " + , prefixText ["C","B","A"] ++ "no-module-selected> C> " ++ reloads ["C", "B", "A"] ++ "C> B> " ++ reloads ["B", "A"] ++ "B> ") , ( map ((testRoot </> "Project" </> "multi-packages") </>) ["package1", "package2"] , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], "" - , oneShotPrefix ["B", "A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = ()\n" + , oneShotPrefix ["B", "A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = ()\n" ) , ( map ((testRoot </> "Project" </> "multi-packages-flags") </>) ["package1", "package2"] , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], "" , oneShotPrefix ["B", "A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = \\case () -> ()\n" ) - , ( map ((testRoot </> "Project" </> "multi-packages-same-module") </>) ["package1", "package2"] - , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"RenameDefinition 3:1-3:2 xx\""], "" - , "Compiling modules. This may take some time. Please wait.\nLoaded module: A\n" - ++ "The following modules are ignored: A. Multiple modules with the same qualified name are not supported.\n" - ++ "All modules loaded.\n" - ++ "### Module changed: A\n### new content:\nmodule A where\n\nxx = ()\n" - ) - , ( [testRoot </> "Project" </> "illegal-extension"] - , ["-dry-run", "-one-shot"] - , "", "Compiling modules. This may take some time. Please wait.\nThe following extensions are not allowed: CPP.\n") + , ( [testRoot </> "Project" </> "with-main"] + , ["-dry-run", "-one-shot", "-module-name=Main", "-refactoring=\"GenerateSignature 3:1\""] + , "", oneShotPrefix ["Main"] ++ "### Module changed: Main\n### new content:\nmodule Main where\n\nmain :: IO ()\nmain = putStrLn \"Hello World\"\n") + , ( [testRoot </> "Project" </> "with-main-renamed"] + , ["-dry-run", "-one-shot", "-module-name=Main", "-refactoring=\"GenerateSignature 3:1\""] + , "", oneShotPrefix ["Main"] ++ "### Module changed: Main\n### new content:\nmodule Main where\n\nmain :: IO ()\nmain = putStrLn \"Hello World\"\n") + , ( [testRoot </> "Project" </> "with-multi-main"], ["-dry-run", "-one-shot", "-module-name=B", "-refactoring=\"RenameDefinition 3:1 bb\""], "" + , oneShotPrefix ["Main", "B", "Main"] + ++ "### Module changed: B\n### new content:\nmodule B where\n\nbb = \"Hello\"\n" + ++ "### Module changed: Main\n### new content:\nmodule Main where\n\nimport B\n\nmain = putStrLn (bb ++ \" World\")\n") + , ( [testRoot </> "Project" </> "with-other-executable"] + , ["-dry-run", "-one-shot", "-module-name=A", "-refactoring=\"GenerateSignature 3:1\""] + , "", oneShotPrefix ["A"] ++ "### Module changed: A\n### new content:\nmodule A where\n\nmain :: IO ()\nmain = putStrLn \"Hello World\"\n") ] benchTests :: IO [TestTree] -benchTests +benchTests = forM ["full-1", "full-2", "full-3"] $ \id -> do commands <- readFile ("bench-tests" </> id <.> "txt") return $ makeCliTest (["examples" </> "CppHs"], [], filter (/='\r') commands, expectedOut id) -expectedOut "full-1" +expectedOut "full-1" = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.CppIfdef> " ++ concat (replicate 8 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> ")) -expectedOut "full-2" +expectedOut "full-2" = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.MacroPass> " ++ concat (replicate 3 (reloads macroPassReloads ++ "Language.Preprocessor.Cpphs.MacroPass> ")) expectedOut "full-3" @@ -107,7 +117,7 @@ ++ "Language.Preprocessor.Cpphs.CppIfdef> " ++ concat (replicate 3 (reloads cppIfDefReloads ++ "Language.Preprocessor.Cpphs.CppIfdef> ")) -cppIfDefReloads = [ "Language.Preprocessor.Cpphs.CppIfdef" +cppIfDefReloads = [ "Language.Preprocessor.Cpphs.CppIfdef" , "Language.Preprocessor.Cpphs.RunCpphs" , "Language.Preprocessor.Cpphs" ] macroPassReloads = "Language.Preprocessor.Cpphs.MacroPass" : cppIfDefReloads @@ -127,20 +137,20 @@ testRoot = "examples" prefixText :: [String] -> String -prefixText mods - = "Compiling modules. This may take some time. Please wait.\n" - ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods +prefixText mods + = "Compiling modules. This may take some time. Please wait.\n" + ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods ++ "All modules loaded. Use 'SelectModule module-name' to select a module.\n" oneShotPrefix :: [String] -> String -oneShotPrefix mods - = "Compiling modules. This may take some time. Please wait.\n" - ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods +oneShotPrefix mods + = "Compiling modules. This may take some time. Please wait.\n" + ++ concatMap (\m -> "Loaded module: " ++ m ++ "\n") mods ++ "All modules loaded.\n" reloads :: [String] -> String -reloads mods = concatMap (\m -> "Re-loaded module: " ++ m ++ "\n") mods +reloads mods = concatMap (\m -> "Re-loaded module: " ++ m ++ "\n") mods copyDir :: FilePath -> FilePath -> IO () copyDir src dst = do @@ -166,4 +176,4 @@ | otherwise = [] longestCommonPrefix :: (Eq a) => [[a]] -> [a] -longestCommonPrefix = foldl1 commonPrefix \ No newline at end of file +longestCommonPrefix = foldl1 commonPrefix diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/test-hackage/Main.hs new/haskell-tools-cli-0.8.0.0/test-hackage/Main.hs --- old/haskell-tools-cli-0.5.0.0/test-hackage/Main.hs 2017-01-31 20:34:13.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/test-hackage/Main.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,72 +0,0 @@ -{-# LANGUAGE LambdaCase - #-} -module Main where - -import Control.Applicative -import Control.Monad -import System.Directory -import System.Process -import System.Environment -import System.Exit -import Data.List -import Data.List.Split - -data Result = GetFailure - | DepInstallFailure - | BuildFailure - | RefactError - | WrongCodeError - | OK - deriving Show - -main :: IO () -main = do args <- getArgs - testHackage args - -testHackage :: [String] -> IO () -testHackage args = do - createDirectoryIfMissing False workDir - withCurrentDirectory workDir $ do - unsetEnv "GHC_PACKAGE_PATH" - callCommand "cabal update" - callCommand "cabal list --simple > packages.txt 2>&1" - packages <- map (map (\case ' ' -> '-'; c -> c)) . lines <$> readFile "packages.txt" - alreadyTested <- if noRetest then do appendFile resultFile "" - map (head . splitOn ";") . filter (not . null) . lines - <$> readFile "results.csv" - else writeFile resultFile "" >> return [] - putStrLn $ "Skipping " ++ show (length alreadyTested) ++ " already tested packages" - let filteredPackages = packages \\ alreadyTested - mapM_ testAndEvaluate filteredPackages - where workDir = "hackage-test" - resultFile = "results.csv" - - noRetest = "-no-retest" `elem` args - testAndEvaluate p = do - res <- testPackage p - appendFile resultFile (p ++ ";" ++ show res ++ "\n") - - -testPackage :: String -> IO Result -testPackage pack = do - downloaded <- doesDirectoryExist pack - getSuccess <- if not downloaded then waitForProcess =<< runCommand ("cabal get " ++ pack) - else return ExitSuccess - case getSuccess of - ExitSuccess -> - withCurrentDirectory pack $ do - callCommand "cabal sandbox init" - runCommands [ ("cabal install -j --only-dependencies --enable-tests --enable-benchmarks > deps-log.txt 2>&1", DepInstallFailure) - , ("cabal configure --enable-tests --enable-benchmarks > config-log.txt 2>&1", BuildFailure) - , ("cabal build -j > build-log.txt 2>&1", BuildFailure) - , ("ht-refact -one-shot -refactoring=ProjectOrganizeImports -package-db .cabal-sandbox\\x86_64-windows-ghc-8.0.1-packages.conf.d . +RTS -M6G -RTS > refact-log.txt 2>&1", RefactError) - , ("cabal build > reload-log.txt 2>&1", WrongCodeError) - ] - ExitFailure _ -> return GetFailure - -runCommands :: [(String, Result)] -> IO Result -runCommands [] = return OK -runCommands ((cmd,failRes):rest) = do - exitCode <- waitForProcess =<< runCommand cmd - case exitCode of ExitSuccess -> runCommands rest - ExitFailure _ -> return failRes \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-cli-0.5.0.0/test-stackage/Main.hs new/haskell-tools-cli-0.8.0.0/test-stackage/Main.hs --- old/haskell-tools-cli-0.5.0.0/test-stackage/Main.hs 2017-01-31 20:34:13.000000000 +0100 +++ new/haskell-tools-cli-0.8.0.0/test-stackage/Main.hs 2017-06-17 11:26:16.000000000 +0200 @@ -1,18 +1,20 @@ -{-# LANGUAGE LambdaCase - #-} +{-# LANGUAGE LambdaCase #-} module Main where import Control.Applicative +import Control.Exception import Control.Monad import System.Directory +import System.IO import System.Process +import System.Timeout import System.Environment import System.Exit import Control.Concurrent import Data.List import Data.List.Split -data Result = GetFailure +data Result = GetFailure | BuildFailure | RefactError | WrongCodeError @@ -24,12 +26,12 @@ testHackage args testHackage :: [String] -> IO () -testHackage args = do +testHackage args = do createDirectoryIfMissing False workDir withCurrentDirectory workDir $ do packages <- lines <$> readFile (last args) - alreadyTested <- if noRetest then do appendFile resultFile "" - map (head . splitOn ";") . filter (not . null) . lines + alreadyTested <- if noRetest then do appendFile resultFile "" + map (head . splitOn ";") . filter (not . null) . lines <$> readFile resultFile else writeFile resultFile "" >> return [] let filteredPackages = packages \\ alreadyTested @@ -39,28 +41,45 @@ resultFile = "results.csv" noRetest = "-no-retest" `elem` args + noLoad = "-no-load" `elem` args testAndEvaluate p = do - res <- testPackage p - appendFile resultFile (p ++ ";" ++ show res ++ "\n") + (res, problem) <- testPackage noLoad p + appendFile resultFile (p ++ ";" ++ show res ++ " ; " ++ problem ++ "\n") -testPackage :: String -> IO Result -testPackage pack = - runCommands [ Left ("cabal get " ++ pack, GetFailure) - , Right $ do threadDelay 1000000 - createDirectoryIfMissing False testedDir +testPackage :: Bool -> String -> IO (Result, String) +testPackage noLoad pack = do + res <- runCommands $ load + ++ [ Left ("stack build --test --no-run-tests --bench --no-run-benchmarks > logs\\" ++ pack ++ "-build-log.txt 2>&1", BuildFailure) + -- correct rts option handling (on windows) requires stack 1.4 + , let autogenPath = "tested-package\\.stack-work\\dist\\" ++ snapshotId ++ "\\build\\autogen" + logPath = "logs\\" ++ pack ++ "-refact-log.txt 2>&1" + dbPaths = ["C:\\Users\\nboldi\\AppData\\Local\\Programs\\stack\\x86_64-windows\\ghc-8.0.2\\lib\\package.conf.d", "C:\\sr\\snapshots\\c095693b\\pkgdb"] + in Left ("stack exec ht-refact --stack-yaml=..\\stack.yaml --rts-options -M4G -- -one-shot -refactoring=ProjectOrganizeImports tested-package " ++ autogenPath ++ " -clear-package-db" ++ concatMap (" -package-db " ++) dbPaths ++ " -package base > " ++ logPath, RefactError) + , Left ("stack build > logs\\" ++ pack ++ "-reload-log.txt 2>&1", WrongCodeError) + ] + problem <- case res of + RefactError -> map (\case '\n' -> ' '; c -> c) <$> readFile ("logs\\" ++ pack ++ "-refact-log.txt") + WrongCodeError -> map (\case '\n' -> ' '; c -> c) <$> readFile ("logs\\" ++ pack ++ "-reload-log.txt") + _ -> return "" + return (res, problem) + where testedDir = "tested-package" + snapshotId = "ca59d0ab" + refreshDir = refreshDir' 5 + refreshDir' n = do createDirectoryIfMissing False testedDir removeDirectoryRecursive testedDir renameDirectory pack testedDir - , Left ("stack build --test --no-run-tests --bench --no-run-benchmarks > logs\\" ++ pack ++ "-build-log.txt 2>&1", BuildFailure) - , Left ("stack exec ht-refact -- -one-shot -refactoring=ProjectOrganizeImports tested-package +RTS -M6G -RTS > logs\\" ++ pack ++ "-refact-log.txt 2>&1", RefactError) - , Left ("stack build > logs\\" ++ pack ++ "-reload-log.txt 2>&1", WrongCodeError) - ] - where testedDir = "tested-package" + `catch` \e -> if n <= 0 + then throwIO (e :: IOException) + else do threadDelay 500000 + refreshDir' (n-1) + load = if noLoad then [] else [ Left ("cabal get " ++ pack, GetFailure), Right refreshDir ] runCommands :: [Either (String, Result) (IO ())] -> IO Result runCommands [] = return OK -runCommands (Left (cmd,failRes) : rest) = do - exitCode <- waitForProcess =<< runCommand cmd +runCommands (Left (cmd,failRes) : rest) = do + pr <- runCommand cmd + exitCode <- waitForProcess pr case exitCode of ExitSuccess -> runCommands rest ExitFailure _ -> return failRes -runCommands (Right act : rest) = act >> runCommands rest \ No newline at end of file +runCommands (Right act : rest) = act >> runCommands rest

1 0

commit ghc-haskell-tools-backend-ghc for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-backend-ghc for openSUSE:Factory checked in at 2017-08-31 20:55:53 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-backend-ghc (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-backend-ghc.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-backend-ghc" Thu Aug 31 20:55:53 2017 rev:2 rq:513369 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-backend-ghc/ghc-haskell-tools-backend-ghc.changes 2017-04-12 18:06:43.234518829 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-backend-ghc.new/ghc-haskell-tools-backend-ghc.changes 2017-08-31 20:55:53.984169140 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:04:32 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-backend-ghc-0.5.0.0.tar.gz New: ---- haskell-tools-backend-ghc-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-backend-ghc.spec ++++++ --- /var/tmp/diff_new_pack.wXIuK8/_old 2017-08-31 20:55:55.000026408 +0200 +++ /var/tmp/diff_new_pack.wXIuK8/_new 2017-08-31 20:55:55.008025284 +0200 @@ -18,7 +18,7 @@ %global pkg_name haskell-tools-backend-ghc Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Creating the Haskell-Tools AST from GHC's representations License: BSD-3-Clause @@ -28,6 +28,7 @@ BuildRequires: ghc-Cabal-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-containers-devel +BuildRequires: ghc-ghc-boot-th-devel BuildRequires: ghc-ghc-devel BuildRequires: ghc-haskell-tools-ast-devel BuildRequires: ghc-mtl-devel ++++++ haskell-tools-backend-ghc-0.5.0.0.tar.gz -> haskell-tools-backend-ghc-0.8.0.0.tar.gz ++++++ ++++ 3040 lines of diff (skipped)

1 0

commit ghc-haskell-tools-ast for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-ast for openSUSE:Factory checked in at 2017-08-31 20:55:51 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-ast (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-ast.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-ast" Thu Aug 31 20:55:51 2017 rev:2 rq:513368 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-ast/ghc-haskell-tools-ast.changes 2017-04-12 18:06:42.482625143 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-ast.new/ghc-haskell-tools-ast.changes 2017-08-31 20:55:52.724346149 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:03:15 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-ast-0.5.0.0.tar.gz New: ---- haskell-tools-ast-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-ast.spec ++++++ --- /var/tmp/diff_new_pack.QbZwND/_old 2017-08-31 20:55:53.640217466 +0200 +++ /var/tmp/diff_new_pack.QbZwND/_new 2017-08-31 20:55:53.644216904 +0200 @@ -18,7 +18,7 @@ %global pkg_name haskell-tools-ast Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Haskell AST for efficient tooling License: BSD-3-Clause ++++++ haskell-tools-ast-0.5.0.0.tar.gz -> haskell-tools-ast-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Ann.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Ann.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Ann.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Ann.hs 2017-05-03 22:13:55.000000000 +0200 @@ -166,7 +166,7 @@ , HasRange (SpanInfo stage) , HasRange (ListInfo stage) , HasRange (OptionalInfo stage) - ) + ) => SourceInfo stage where -- | UType of source info for normal AST elements data SpanInfo stage :: * @@ -182,13 +182,13 @@ data ListInfo RangeStage = ListPos { _listBefore :: String , _listAfter :: String , _listDefaultSep :: String - , _listIndented :: Bool - , _listPos :: SrcLoc + , _listIndented :: Maybe [Bool] + , _listPos :: SrcLoc } deriving (Data) data OptionalInfo RangeStage = OptionalPos { _optionalBefore :: String - , _optionalAfter :: String - , _optionalPos :: SrcLoc + , _optionalAfter :: String + , _optionalPos :: SrcLoc } deriving (Data) @@ -207,13 +207,13 @@ data ListInfo NormRangeStage = NormListInfo { _normListBefore :: String , _normListAfter :: String , _normListDefaultSep :: String - , _normListIndented :: Bool - , _normListSpan :: SrcSpan + , _normListIndented :: Maybe [Bool] + , _normListSpan :: SrcSpan } deriving (Data) data OptionalInfo NormRangeStage = NormOptInfo { _normOptBefore :: String - , _normOptAfter :: String - , _normOptSpan :: SrcSpan + , _normOptAfter :: String + , _normOptSpan :: SrcSpan } deriving (Data) @@ -228,8 +228,8 @@ -- | A short form of showing a range, without file name, for debugging purposes. shortShowSpan :: SrcSpan -> String -shortShowSpan (UnhelpfulSpan _) = "??-??" -shortShowSpan sp@(RealSrcSpan _) +shortShowSpan (UnhelpfulSpan _) = "??-??" +shortShowSpan sp@(RealSrcSpan _) = shortShowLoc (srcSpanStart sp) ++ "-" ++ shortShowLoc (srcSpanEnd sp) -- | A short form of showing a range, without file name, for debugging purposes. @@ -239,7 +239,7 @@ -- | A class for marking a source information stage. All programs, regardless of -- correct Haskell programs or not, must go through these stages to be refactored. -class SourceInfo stage +class SourceInfo stage => RangeInfo stage where nodeSpan :: Simple Lens (SpanInfo stage) GHC.SrcSpan listPos :: Simple Lens (ListInfo stage) GHC.SrcLoc @@ -253,40 +253,40 @@ -- * Annotations -- | Semantic and source code related information for an AST node. -data NodeInfo sema src +data NodeInfo sema src = NodeInfo { _semanticInfo :: sema , _sourceInfo :: src } deriving (Eq, Show, Data) - + makeReferences ''NodeInfo -- | An element of the AST keeping extra information. data Ann elem dom stage -- The type parameters are organized this way because we want the annotation type to --- be more flexible, but the annotation is the first parameter because it eases +-- be more flexible, but the annotation is the first parameter because it eases -- pattern matching. = Ann { _annotation :: NodeInfo (SemanticInfo dom elem) (SpanInfo stage) -- ^ The extra information for the AST part , _element :: elem dom stage -- ^ The original AST part } - + makeReferences ''Ann -- | A list of AST elements -data AnnListG elem dom stage = AnnListG { _annListAnnot :: NodeInfo (SemanticInfo dom (AnnListG elem)) (ListInfo stage) +data AnnListG elem dom stage = AnnListG { _annListAnnot :: NodeInfo (SemanticInfo dom (AnnListG elem)) (ListInfo stage) , _annListElems :: [Ann elem dom stage] } makeReferences ''AnnListG - -annList :: Traversal (AnnListG e d s) (AnnListG e d s) (Ann e d s) (Ann e d s) + +annList :: Traversal (AnnListG e d s) (AnnListG e d s) (Ann e d s) (Ann e d s) annList = annListElems & traversal -- | An optional AST element data AnnMaybeG elem dom stage = AnnMaybeG { _annMaybeAnnot :: NodeInfo (SemanticInfo dom (AnnMaybeG elem)) (OptionalInfo stage) , _annMaybe :: Maybe (Ann elem dom stage) } - + makeReferences ''AnnMaybeG class HasSourceInfo e where @@ -304,8 +304,8 @@ instance HasSourceInfo (AnnMaybeG elem dom stage) where type SourceInfoType (AnnMaybeG elem dom stage) = OptionalInfo stage srcInfo = annMaybeAnnot & sourceInfo - -annJust :: Partial (AnnMaybeG e d s) (AnnMaybeG e d s) (Ann e d s) (Ann e d s) + +annJust :: Partial (AnnMaybeG e d s) (AnnMaybeG e d s) (Ann e d s) (Ann e d s) annJust = annMaybe & just -- | An empty list of AST elements @@ -366,7 +366,7 @@ setRange sp = annMaybeAnnot & sourceInfo .- setRange sp -- | A class for changing semantic information throught the AST. -class ApplySemaChange cls where +class ApplySemaChange cls where appSemaChange :: SemaTrf f dom1 dom2 -> SemanticInfo' dom1 cls -> f (SemanticInfo' dom2 cls) instance ApplySemaChange SameInfoNameCls where appSemaChange = trfSemaNameCls @@ -377,7 +377,7 @@ instance ApplySemaChange SameInfoDefaultCls where appSemaChange = trfSemaDefault -- | A class for traversing semantic information in an AST -class ApplySemaChange (SemaInfoClassify a) +class ApplySemaChange (SemaInfoClassify a) => SemanticTraversal a where semaTraverse :: Monad f => SemaTrf f dom1 dom2 -> a dom1 st -> f (a dom2 st) @@ -412,26 +412,25 @@ } instance SourceInfoTraversal e => SourceInfoTraversal (Ann e) where - sourceInfoTraverse trf (Ann (NodeInfo sema src) e) + sourceInfoTraverse trf (Ann (NodeInfo sema src) e) = Ann <$> (NodeInfo sema <$> trfSpanInfo trf src) <*> sourceInfoTraverse trf e - sourceInfoTraverseDown trf desc asc (Ann (NodeInfo sema src) e) + sourceInfoTraverseDown trf desc asc (Ann (NodeInfo sema src) e) = Ann <$> (NodeInfo sema <$> trfSpanInfo trf src) <*> (desc *> sourceInfoTraverseDown trf desc asc e <* asc) - sourceInfoTraverseUp trf desc asc (Ann (NodeInfo sema src) e) + sourceInfoTraverseUp trf desc asc (Ann (NodeInfo sema src) e) = flip Ann <$> (desc *> sourceInfoTraverseUp trf desc asc e <* asc) <*> (NodeInfo sema <$> trfSpanInfo trf src) instance SourceInfoTraversal e => SourceInfoTraversal (AnnListG e) where - sourceInfoTraverse trf (AnnListG (NodeInfo sema src) e) + sourceInfoTraverse trf (AnnListG (NodeInfo sema src) e) = AnnListG <$> (NodeInfo sema <$> trfListInfo trf src) <*> mapM (sourceInfoTraverse trf) e - sourceInfoTraverseDown trf desc asc (AnnListG (NodeInfo sema src) e) + sourceInfoTraverseDown trf desc asc (AnnListG (NodeInfo sema src) e) = AnnListG <$> (NodeInfo sema <$> trfListInfo trf src) <*> (desc *> mapM (sourceInfoTraverseDown trf desc asc) e <* asc) - sourceInfoTraverseUp trf desc asc (AnnListG (NodeInfo sema src) e) + sourceInfoTraverseUp trf desc asc (AnnListG (NodeInfo sema src) e) = flip AnnListG <$> (desc *> mapM (sourceInfoTraverseUp trf desc asc) e <* asc) <*> (NodeInfo sema <$> trfListInfo trf src) instance SourceInfoTraversal e => SourceInfoTraversal (AnnMaybeG e) where - sourceInfoTraverse trf (AnnMaybeG (NodeInfo sema src) e) + sourceInfoTraverse trf (AnnMaybeG (NodeInfo sema src) e) = AnnMaybeG <$> (NodeInfo sema <$> trfOptionalInfo trf src) <*> sequence (fmap (sourceInfoTraverse trf) e) - sourceInfoTraverseDown trf desc asc (AnnMaybeG (NodeInfo sema src) e) + sourceInfoTraverseDown trf desc asc (AnnMaybeG (NodeInfo sema src) e) = AnnMaybeG <$> (NodeInfo sema <$> trfOptionalInfo trf src) <*> (desc *> sequence (fmap (sourceInfoTraverseDown trf desc asc) e) <* asc) - sourceInfoTraverseUp trf desc asc (AnnMaybeG (NodeInfo sema src) e) + sourceInfoTraverseUp trf desc asc (AnnMaybeG (NodeInfo sema src) e) = flip AnnMaybeG <$> (desc *> sequence (fmap (sourceInfoTraverseUp trf desc asc) e) <* asc) <*> (NodeInfo sema <$> trfOptionalInfo trf src) - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Helpers.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Helpers.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Helpers.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Helpers.hs 2017-05-22 15:12:54.000000000 +0200 @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts - , LambdaCase - , RankNTypes +{-# LANGUAGE FlexibleContexts + , LambdaCase + , RankNTypes , ScopedTypeVariables , TypeFamilies , FlexibleInstances @@ -29,14 +29,18 @@ import Language.Haskell.Tools.AST.Representation.Patterns (UPattern) import Language.Haskell.Tools.AST.Representation.Types (UType(..)) import Language.Haskell.Tools.AST.SemaInfoTypes (Scope) - + -- | Does the import declaration import only the explicitly listed elements? importIsExact :: Ann UImportDecl dom stage -> Bool -importIsExact = isJust . (^? importSpec&annJust&importSpecList) +importIsExact = isJust . (^? importSpec&annJust&importSpecList) + +-- | Does the import declaration import all elements that are not excluded explicitly? +importIsHiding :: Ann UImportDecl dom stage -> Bool +importIsHiding = isJust . (^? importSpec&annJust&importSpecHiding) -- | Accesses the name of a function or value binding bindingName :: Simple Traversal (Ann UValueBind dom stage) (Ann UQualifiedName dom stage) -bindingName = (valBindPat&patternName&simpleName +bindingName = (valBindPat&patternName&simpleName &+& funBindMatches&annList&matchLhs &(matchLhsName&simpleName &+& matchLhsOperator&operatorName)) @@ -62,9 +66,9 @@ semantics = annotation&semanticInfo -- | Get all nodes that contain a given source range -nodesContaining :: (HasRange (inner dom stage), Biplate (node dom stage) (inner dom stage)) +nodesContaining :: (HasRange (inner dom stage), Biplate (node dom stage) (inner dom stage)) => RealSrcSpan -> Simple Traversal (node dom stage) (inner dom stage) -nodesContaining rng = biplateRef & filtered (isInside rng) +nodesContaining rng = biplateRef & filtered (isInside rng) -- | Return true if the node contains a given range isInside :: HasRange (inner dom stage) => RealSrcSpan -> inner dom stage -> Bool @@ -72,26 +76,26 @@ _ -> False -- | Get all nodes that are contained in a given source range -nodesContained :: (HasRange (inner dom stage), Biplate (node dom stage) (inner dom stage)) +nodesContained :: (HasRange (inner dom stage), Biplate (node dom stage) (inner dom stage)) => RealSrcSpan -> Simple Traversal (node dom stage) (inner dom stage) -nodesContained rng = biplateRef & filtered (isContained rng) +nodesContained rng = biplateRef & filtered (isContained rng) -- | Return true if the node contains a given range isContained :: HasRange (inner dom stage) => RealSrcSpan -> inner dom stage -> Bool isContained rng nd = case getRange nd of RealSrcSpan sp -> rng `containsSpan` sp _ -> False --- | Get the nodes that have exactly the given range -nodesWithRange :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage) +-- | Get the nodes that have exactly the given range +nodesWithRange :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage) => RealSrcSpan -> Simple Traversal (Ann node dom stage) (Ann inner dom stage) -nodesWithRange rng = biplateRef & filtered (hasRange rng) - where -- True, if the node has the given range +nodesWithRange rng = biplateRef & filtered (hasRange rng) + where -- True, if the node has the given range hasRange :: SourceInfo stage => RealSrcSpan -> Ann inner dom stage -> Bool hasRange rng node = case getRange node of RealSrcSpan sp -> sp == rng _ -> False --- | Get the shortest source range that contains the given -getNodeContaining :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage, HasRange (Ann inner dom stage)) +-- | Get the shortest source range that contains the given +getNodeContaining :: (Biplate (Ann node dom stage) (Ann inner dom stage), SourceInfo stage, HasRange (Ann inner dom stage)) => RealSrcSpan -> Ann node dom stage -> Maybe (Ann inner dom stage) getNodeContaining sp node = case node ^? nodesContaining sp of [] -> Nothing @@ -110,22 +114,22 @@ elementName :: Simple Traversal (Ann elem dom st) (Ann UQualifiedName dom st) instance NamedElement UDecl where - elementName = (declHead & declHeadNames) + elementName = (declHead & declHeadNames) &+& (declTypeFamily & tfHead & declHeadNames) &+& (declValBind & bindingName) &+& (declName & simpleName) &+& (declPatSyn & patLhs & (patName & simpleName &+& patSynOp & operatorName)) instance NamedElement ULocalBind where - elementName = localVal&bindingName - &+& localSig&tsName&annList&simpleName + elementName = localVal&bindingName + &+& localSig&tsName&annList&simpleName &+& localFixity&fixityOperators&annList&operatorName inScope :: GHC.Name -> Scope -> Bool -inScope n sc = any (n `elem`) sc +inScope n sc = any ((n `elem`) . map fst) sc -- * Pattern synonyms for annotated lists and maybes - + pattern AnnList :: [Ann elem dom stage] -> AnnListG elem dom stage pattern AnnList elems <- AnnListG _ elems @@ -133,4 +137,4 @@ pattern AnnNothing <- AnnMaybeG _ Nothing pattern AnnJust :: Ann elem dom stage -> AnnMaybeG elem dom stage -pattern AnnJust elem <- AnnMaybeG _ (Just elem) \ No newline at end of file +pattern AnnJust elem <- AnnMaybeG _ (Just elem) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Data.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Data.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Data.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Data.hs 2017-05-17 10:56:30.000000000 +0200 @@ -80,6 +80,7 @@ deriving instance (Domain dom, SourceInfo stage) => Data (UBracket dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UTopLevelPragma dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (URule dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (URuleVar dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UAnnotationSubject dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UMinimalFormula dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UExprPragma dom stage) @@ -108,6 +109,7 @@ deriving instance (Domain dom, SourceInfo stage) => Data (ULanguageExtension dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UMatchLhs dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UInlinePragma dom stage) +deriving instance (Domain dom, SourceInfo stage) => Data (USpecializePragma dom stage) -- ULiteral deriving instance (Domain dom, SourceInfo stage) => Data (ULiteral dom stage) @@ -133,4 +135,4 @@ deriving instance (Domain dom, SourceInfo stage) => Data (LineNumber dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (UPhaseControl dom stage) deriving instance (Domain dom, SourceInfo stage) => Data (PhaseNumber dom stage) -deriving instance (Domain dom, SourceInfo stage) => Data (PhaseInvert dom stage) \ No newline at end of file +deriving instance (Domain dom, SourceInfo stage) => Data (PhaseInvert dom stage) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Eq.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Eq.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Eq.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Eq.hs 2017-05-17 10:56:30.000000000 +0200 @@ -83,6 +83,7 @@ deriving instance Eq (UBracket dom stage) deriving instance Eq (UTopLevelPragma dom stage) deriving instance Eq (URule dom stage) +deriving instance Eq (URuleVar dom stage) deriving instance Eq (UAnnotationSubject dom stage) deriving instance Eq (UMinimalFormula dom stage) deriving instance Eq (UExprPragma dom stage) @@ -111,6 +112,7 @@ deriving instance Eq (ULanguageExtension dom stage) deriving instance Eq (UMatchLhs dom stage) deriving instance Eq (UInlinePragma dom stage) +deriving instance Eq (USpecializePragma dom stage) -- ULiteral deriving instance Eq (ULiteral dom stage) @@ -136,4 +138,4 @@ deriving instance Eq (LineNumber dom stage) deriving instance Eq (UPhaseControl dom stage) deriving instance Eq (PhaseNumber dom stage) -deriving instance Eq (PhaseInvert dom stage) \ No newline at end of file +deriving instance Eq (PhaseInvert dom stage) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Generic.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Generic.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Generic.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Generic.hs 2017-05-17 10:56:30.000000000 +0200 @@ -80,6 +80,7 @@ deriving instance Domain dom => Generic (UBracket dom stage) deriving instance Domain dom => Generic (UTopLevelPragma dom stage) deriving instance Domain dom => Generic (URule dom stage) +deriving instance Domain dom => Generic (URuleVar dom stage) deriving instance Domain dom => Generic (UAnnotationSubject dom stage) deriving instance Domain dom => Generic (UMinimalFormula dom stage) deriving instance Domain dom => Generic (UExprPragma dom stage) @@ -108,6 +109,7 @@ deriving instance Domain dom => Generic (ULanguageExtension dom stage) deriving instance Domain dom => Generic (UMatchLhs dom stage) deriving instance Domain dom => Generic (UInlinePragma dom stage) +deriving instance Domain dom => Generic (USpecializePragma dom stage) -- Literal @@ -134,4 +136,4 @@ deriving instance Domain dom => Generic (LineNumber dom stage) deriving instance Domain dom => Generic (UPhaseControl dom stage) deriving instance Domain dom => Generic (PhaseNumber dom stage) -deriving instance Domain dom => Generic (PhaseInvert dom stage) \ No newline at end of file +deriving instance Domain dom => Generic (PhaseInvert dom stage) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/SemanticTraversal.hs 2017-05-17 10:56:30.000000000 +0200 @@ -76,6 +76,7 @@ deriveSemanticTraversal ''UBracket deriveSemanticTraversal ''UTopLevelPragma deriveSemanticTraversal ''URule +deriveSemanticTraversal ''URuleVar deriveSemanticTraversal ''UAnnotationSubject deriveSemanticTraversal ''UMinimalFormula deriveSemanticTraversal ''UExprPragma @@ -106,6 +107,7 @@ deriveSemanticTraversal ''UCaseRhs' deriveSemanticTraversal ''UGuardedCaseRhs' deriveSemanticTraversal ''UInlinePragma +deriveSemanticTraversal ''USpecializePragma -- ULiteral deriveSemanticTraversal ''ULiteral diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Show.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Show.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/Show.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/Show.hs 2017-05-17 10:56:30.000000000 +0200 @@ -21,7 +21,7 @@ instance (Show (e dom stage)) => Show (AnnMaybeG e dom stage) where show (AnnMaybeG _ e) = show e - + instance (Show (e dom stage)) => Show (AnnListG e dom stage) where show (AnnListG _ e) = show e @@ -83,6 +83,7 @@ deriving instance Show (UBracket dom stage) deriving instance Show (UTopLevelPragma dom stage) deriving instance Show (URule dom stage) +deriving instance Show (URuleVar dom stage) deriving instance Show (UAnnotationSubject dom stage) deriving instance Show (UMinimalFormula dom stage) deriving instance Show (UExprPragma dom stage) @@ -111,6 +112,7 @@ deriving instance Show (ULanguageExtension dom stage) deriving instance Show (UMatchLhs dom stage) deriving instance Show (UInlinePragma dom stage) +deriving instance Show (USpecializePragma dom stage) -- ULiteral @@ -137,4 +139,4 @@ deriving instance Show (LineNumber dom stage) deriving instance Show (UPhaseControl dom stage) deriving instance Show (PhaseNumber dom stage) -deriving instance Show (PhaseInvert dom stage) \ No newline at end of file +deriving instance Show (PhaseInvert dom stage) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Instances/SourceInfoTraversal.hs 2017-05-17 10:56:30.000000000 +0200 @@ -76,6 +76,7 @@ deriveSourceInfoTraversal ''UBracket deriveSourceInfoTraversal ''UTopLevelPragma deriveSourceInfoTraversal ''URule +deriveSourceInfoTraversal ''URuleVar deriveSourceInfoTraversal ''UAnnotationSubject deriveSourceInfoTraversal ''UMinimalFormula deriveSourceInfoTraversal ''UExprPragma @@ -106,6 +107,7 @@ deriveSourceInfoTraversal ''UCaseRhs' deriveSourceInfoTraversal ''UGuardedCaseRhs' deriveSourceInfoTraversal ''UInlinePragma +deriveSourceInfoTraversal ''USpecializePragma -- ULiteral deriveSourceInfoTraversal ''ULiteral diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/References.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/References.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/References.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/References.hs 2017-05-03 22:13:55.000000000 +0200 @@ -66,6 +66,7 @@ $(toASTReferences (makeReferences ''UInstanceHead)) $(toASTReferences (makeReferences ''UTypeEqn)) $(toASTReferences (makeReferences ''URule)) +$(toASTReferences (makeReferences ''URuleVar)) $(toASTReferences (makeReferences ''UOverlapPragma)) $(toASTReferences (makeReferences ''UCallConv)) $(toASTReferences (makeReferences ''USafety)) @@ -139,4 +140,3 @@ $(toASTReferences (makeReferences ''UQualifiedName)) $(toASTReferences (makeReferences ''UNamePart)) $(toASTReferences (makeReferences ''UStringNode)) - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Binds.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Binds.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Binds.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Binds.hs 2017-05-03 22:13:55.000000000 +0200 @@ -12,17 +12,17 @@ = USimpleBind { _valBindPat :: Ann UPattern dom stage , _valBindRhs :: Ann URhs dom stage , _valBindLocals :: AnnMaybeG ULocalBinds dom stage - } -- ^ Non-function binding (@ v = "12" @) + } -- ^ Non-function binding (@ v = "12" @) -- TODO: use one name for a function instead of names in each match | UFunBind { _funBindMatches :: AnnListG UMatch dom stage } -- ^ Function binding (@ f 0 = 1; f x = x @). All matches must have the same name. --- | Clause of function binding +-- | Clause of function binding data UMatch dom stage = UMatch { _matchLhs :: Ann UMatchLhs dom stage , _matchRhs :: Ann URhs dom stage , _matchBinds :: AnnMaybeG ULocalBinds dom stage - } + } -- | Something on the left side of the match data UMatchLhs dom stage @@ -34,12 +34,12 @@ , _matchLhsRhs :: Ann UPattern dom stage , _matchLhsArgs :: AnnListG UPattern dom stage } -- ^ An infix match lhs for an operator (@ a + b @) - --- | Local bindings attached to a declaration (@ where x = 42 @) + +-- | Local bindings attached to a declaration (@ where x = 42 @) data ULocalBinds dom stage = ULocalBinds { _localBinds :: AnnListG ULocalBind dom stage } - + -- | Bindings that are enabled in local blocks (where or let). data ULocalBind dom stage -- TODO: check that no other signature can be inside a local binding @@ -51,13 +51,13 @@ } -- ^ A local fixity declaration | ULocalInline { _localInline :: Ann UInlinePragma dom stage } -- ^ A local inline pragma - + -- | A type signature (@ f :: Int -> Int @) data UTypeSignature dom stage = UTypeSignature { _tsName :: AnnListG UName dom stage , _tsType :: Ann UType dom stage - } - + } + -- * Fixities -- | A fixity signature (@ infixl 5 +, - @). @@ -72,10 +72,10 @@ = AssocNone -- ^ non-associative operator (declared with @infix@) | AssocLeft -- ^ left-associative operator (declared with @infixl@) | AssocRight -- ^ right-associative operator (declared with @infixr@) - + -- | Numeric precedence of an operator data Precedence dom stage - = Precedence { _precedenceValue :: Int } + = Precedence { _precedenceValue :: Int } -- | Right hand side of a value binding (possible with guards): (@ = 3 @ or @ | x == 1 = 3; | otherwise = 4 @) data URhs dom stage @@ -83,12 +83,12 @@ } -- ^ An unguarded right-hand-side (@ = 3 @) | UGuardedRhss { _rhsGuards :: AnnListG UGuardedRhs dom stage } -- ^ An unguarded right-hand-side (@ | x == 1 = 3; | otherwise = 4 @) - --- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) + +-- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) data UGuardedRhs dom stage = UGuardedRhs { _guardStmts :: AnnListG URhsGuard dom stage -- ^ Cannot be empty. , _guardExpr :: Ann UExpr dom stage - } + } -- | Guards for value bindings and pattern matches (@ Just v <- x, v > 1 @) data URhsGuard dom stage @@ -118,12 +118,12 @@ -- | Controls the activation of a rewrite rule (@ [1] @) data UPhaseControl dom stage = UPhaseControl { _phaseUntil :: AnnMaybeG PhaseInvert dom stage - , _phaseNumber :: Ann PhaseNumber dom stage - } + , _phaseNumber :: AnnMaybeG PhaseNumber dom stage + } -- | Phase number for rewrite rules data PhaseNumber dom stage = PhaseNumber { _phaseNum :: Integer } -- | A tilde that marks the inversion of the phase number -data PhaseInvert dom stage = PhaseInvert \ No newline at end of file +data PhaseInvert dom stage = PhaseInvert diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Decls.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Decls.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Decls.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Decls.hs 2017-05-17 13:32:17.000000000 +0200 @@ -1,4 +1,4 @@ --- | Representation of Haskell AST definitions. These include definition of data types, classes, instances and so on. +-- | Representation of Haskell AST definitions. These include definition of data types, classes, instances and so on. -- The definition of value bindings are in the Binds module. module Language.Haskell.Tools.AST.Representation.Decls where @@ -21,7 +21,7 @@ | UTypeFamilyDecl { _declTypeFamily :: Ann UTypeFamily dom stage } -- ^ A type family declaration ( @type family F x@ ) | UClosedTypeFamilyDecl { _declHead :: Ann UDeclHead dom stage - , _declKind :: AnnMaybeG UKindConstraint dom stage + , _declSpec :: AnnMaybeG UTypeFamilySpec dom stage , _declDecl :: AnnListG UTypeEqn dom stage -- ^ cannot be empty } -- ^ A closed type family declaration | UDataDecl { _declNewtype :: Ann UDataOrNewtypeKeyword dom stage @@ -29,7 +29,7 @@ , _declHead :: Ann UDeclHead dom stage , _declCons :: AnnListG UConDecl dom stage , _declDeriving :: AnnMaybeG UDeriving dom stage - } -- ^ A data or newtype declaration. Empty data type declarations without + } -- ^ A data or newtype declaration. Empty data type declarations without -- where keyword are always belong to DataDecl. | UGDataDecl { _declNewtype :: Ann UDataOrNewtypeKeyword dom stage , _declCtx :: AnnMaybeG UContext dom stage @@ -78,11 +78,11 @@ | UForeignImport { _declCallConv :: Ann UCallConv dom stage , _declSafety :: AnnMaybeG USafety dom stage , _declName :: Ann UName dom stage - , _declType :: Ann UType dom stage + , _declForeignType :: Ann UType dom stage } -- ^ Foreign import (@ foreign import _foo :: Int -> IO Int @) | UForeignExport { _declCallConv :: Ann UCallConv dom stage , _declName :: Ann UName dom stage - , _declType :: Ann UType dom stage + , _declForeignType :: Ann UType dom stage } -- ^ Foreign export (@ foreign export ccall _foo :: Int -> IO Int @) | UPragmaDecl { _declPragma :: Ann UTopLevelPragma dom stage } -- ^ Top-level pragmas @@ -112,18 +112,20 @@ data UClassBody dom stage = UClassBody { _cbElements :: AnnListG UClassElement dom stage } - --- | Members of a class declaration + +-- | Members of a class declaration data UClassElement dom stage = UClsSig { _ceTypeSig :: Ann UTypeSignature dom stage } -- ^ Signature: @ f :: A -> B @ + | UClsFixity { _clsFixity :: Ann UFixitySignature dom stage + } -- ^ Fixity signature in class: @ infixl 1 >>- @ | UClsDef { _ceBind :: Ann UValueBind dom stage } -- ^ Default binding: @ f x = "aaa" @ | UClsTypeFam { _ceTypeFam :: Ann UTypeFamily dom stage - } -- ^ Declaration of an associated type synonym: @ type T x :: * @ + } -- ^ Declaration of an associated type synonym: @ type T x :: * @ | UClsTypeDef { _ceHead :: Ann UDeclHead dom stage , _ceKind :: Ann UType dom stage - } -- ^ Default choice for type synonym: @ type T x = TE @ or @ type instance T x = TE @ + } -- ^ Default choice for type synonym: @ type T x = TE @ or @ type instance T x = TE @ | UClsDefSig { _ceName :: Ann UName dom stage , _ceType :: Ann UType dom stage } -- ^ Default signature (by using @DefaultSignatures@): @ default _enum :: (Generic a, GEnum (Rep a)) => [a] @ @@ -136,7 +138,7 @@ -- } -- ^ Pattern signature in a class declaration (by using @PatternSynonyms@) -- * Type class instances - + -- | The instance declaration rule, which is, roughly, the part of the instance declaration before the where keyword. data UInstanceRule dom stage = UInstanceRule { _irVars :: AnnMaybeG (AnnListG UTyVar) dom stage @@ -149,7 +151,7 @@ = UInstanceHeadCon { _ihConName :: Ann UName dom stage } -- ^ Type or class name | UInstanceHeadInfix { _ihLeftOp :: Ann UType dom stage - , _ihOperator :: Ann UName dom stage + , _ihOperator :: Ann UOperator dom stage } -- ^ Infix application of the type/class name to the left operand | UInstanceHeadParen { _ihHead :: Ann UInstanceHead dom stage } -- ^ Parenthesized instance head @@ -185,11 +187,13 @@ } -- ^ Specialize instance pragma (no phase selection is allowed) | UInlineInstance { _instanceInline :: Ann UInlinePragma dom stage } -- ^ Inline-like pragma in a class instance + | UInstanceSpecialize { _specializeInstance :: Ann USpecializePragma dom stage + } -- ^ Specialize pragma -- not supported yet -- | UInstBodyPatSyn { _instBodyPatSyn :: Ann UPatternSynonym dom stage -- } -- ^ A pattern synonym in a class instance --- | Overlap pragmas. Can be applied to class declarations and class instance declarations. +-- | Overlap pragmas. Can be applied to class declarations and class instance declarations. data UOverlapPragma dom stage = UEnableOverlap -- ^ @OVERLAP@ pragma | UDisableOverlap -- ^ @NO_OVERLAP@ pragma @@ -218,7 +222,7 @@ -- | Injectivity annotation for type families (@ = r | r -> a @) data UInjectivityAnn dom stage - = UInjectivityAnn { _injAnnRes :: Ann UName dom stage + = UInjectivityAnn { _injAnnRes :: Ann UTyVar dom stage , _injAnnDeps :: AnnListG UName dom stage } @@ -233,9 +237,11 @@ -- | GADT constructor declaration (@ D1 :: { val :: Int } -> T String @) data UGadtConDecl dom stage = UGadtConDecl { _gadtConNames :: AnnListG UName dom stage + , _gadtConTypeArgs :: AnnListG UTyVar dom stage + , _gadtConTypeCtx :: AnnMaybeG UContext dom stage , _gadtConType :: Ann UGadtConType dom stage } - + -- | The @data@ or the @newtype@ keyword to define ADTs. data UDataOrNewtypeKeyword dom stage = UDataKeyword @@ -249,36 +255,42 @@ , _gadtConResultType :: Ann UType dom stage } --- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas +-- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas data UFunDeps dom stage = UFunDeps { _funDeps :: AnnListG UFunDep dom stage - } - --- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ + } + +-- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ data UFunDep dom stage = UFunDep { _funDepLhs :: AnnListG UName dom stage , _funDepRhs :: AnnListG UName dom stage } - + -- | A constructor declaration for a datatype data UConDecl dom stage - = UConDecl { _conDeclName :: Ann UName dom stage + = UConDecl { _conTypeArgs :: AnnListG UTyVar dom stage + , _conTypeCtx :: AnnMaybeG UContext dom stage + , _conDeclName :: Ann UName dom stage , _conDeclArgs :: AnnListG UType dom stage } -- ^ Ordinary data constructor (@ C t1 t2 @) - | URecordDecl { _conDeclName :: Ann UName dom stage + | URecordDecl { _conTypeArgs :: AnnListG UTyVar dom stage + , _conTypeCtx :: AnnMaybeG UContext dom stage + , _conDeclName :: Ann UName dom stage , _conDeclFields :: AnnListG UFieldDecl dom stage } -- ^ Record data constructor (@ C { _n1 :: t1, _n2 :: t2 } @) - | UInfixConDecl { _conDeclLhs :: Ann UType dom stage + | UInfixConDecl { _conTypeArgs :: AnnListG UTyVar dom stage + , _conTypeCtx :: AnnMaybeG UContext dom stage + , _conDeclLhs :: Ann UType dom stage , _conDeclOp :: Ann UOperator dom stage , _conDeclRhs :: Ann UType dom stage } -- ^ Infix data constructor (@ t1 :+: t2 @) - + -- | Field declaration (@ fld :: Int @) data UFieldDecl dom stage = UFieldDecl { _fieldNames :: AnnListG UName dom stage , _fieldType :: Ann UType dom stage } - + -- | A deriving clause following a data type declaration. (@ deriving Show @ or @ deriving (Show, Eq) @) data UDeriving dom stage = UDerivingOne { _oneDerived :: Ann UInstanceHead dom stage } @@ -290,7 +302,7 @@ data UPatternTypeSignature dom stage = UPatternTypeSignature { _patSigName :: Ann UName dom stage , _patSigType :: Ann UType dom stage - } + } -- | Pattern synonyms: @ pattern Arrow t1 t2 = App "->" [t1, t2] @ data UPatternSynonym dom stage @@ -325,7 +337,7 @@ = UPatSynWhere { _patOpposite :: AnnListG UMatch dom stage } -- * Foreign imports - + -- | Call conventions of foreign functions data UCallConv dom stage = UStdCall @@ -359,10 +371,10 @@ = URulePragma { _pragmaRule :: AnnListG URule dom stage } -- ^ A pragma that introduces source rewrite rules (@ {-# RULES "map/map" [2] forall f g xs. map f (map g xs) = map (f.g) xs #-} @) | UDeprPragma { _pragmaObjects :: AnnListG UName dom stage - , _pragmaMessage :: Ann UStringNode dom stage + , _deprMessage :: AnnListG UStringNode dom stage } -- ^ A pragma that marks definitions as deprecated (@ {-# DEPRECATED f "f will be replaced by g" @) | UWarningPragma { _pragmaObjects :: AnnListG UName dom stage - , _pragmaMessage :: Ann UStringNode dom stage + , _warnMessage :: AnnListG UStringNode dom stage } -- ^ A pragma that marks definitions as deprecated (@ {-# WARNING unsafePerformIO "you should know what you are doing" @) | UAnnPragma { _annotationSubject :: Ann UAnnotationSubject dom stage , _annotateExpr :: Ann UExpr dom stage @@ -372,7 +384,10 @@ | ULinePragma { _pragmaLineNum :: Ann LineNumber dom stage , _pragmaFileName :: AnnMaybeG UStringNode dom stage } -- ^ A pragma for maintaining line numbers in generated sources (@ {-# LINE 123 "somefile" #-} @) - | USpecializePragma { _pragmaPhase :: AnnMaybeG UPhaseControl dom stage + | USpecializeDecl { _specializePragma :: Ann USpecializePragma dom stage } + +data USpecializePragma dom stage + = USpecializePragma { _pragmaPhase :: AnnMaybeG UPhaseControl dom stage , _specializeDef :: Ann UName dom stage , _specializeType :: AnnListG UType dom stage } -- ^ A pragma that tells the compiler that a polymorph function should be optimized for a given type (@ {-# SPECIALISE f :: Int -> b -> b #-} @) @@ -381,12 +396,20 @@ data URule dom stage = URule { _ruleName :: Ann UStringNode dom stage -- ^ User name of the rule , _rulePhase :: AnnMaybeG UPhaseControl dom stage -- ^ The compilation phases in which the rule can be applied - , _ruleBounded :: AnnListG UTyVar dom stage -- ^ Variables bound in the rule + , _ruleBounded :: AnnListG URuleVar dom stage -- ^ Variables bound in the rule , _ruleLhs :: Ann UExpr dom stage -- ^ The transformed expression , _ruleRhs :: Ann UExpr dom stage -- ^ The resulting expression } - --- | Annotation allows you to connect an expression to any declaration. + +-- | A variable for a rewrite rule. With or without type signature. +data URuleVar dom stage + = URuleVar { _ruleVarName :: Ann UName dom stage + } -- ^ A simple rule variable + | USigRuleVar { _ruleVarName :: Ann UName dom stage + , _ruleVarType :: Ann UType dom stage + } -- ^ A rule variable with signature + +-- | Annotation allows you to connect an expression to any declaration. data UAnnotationSubject dom stage = UNameAnnotation { _annotateName :: Ann UName dom stage } -- ^ The definition with the given name is annotated @@ -407,4 +430,4 @@ -- | A line number for a line pragma. data LineNumber dom stage - = LineNumber { _lineNumber :: Int } + = LineNumber { _lineNumber :: Int } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Exprs.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Exprs.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Exprs.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Exprs.hs 2017-05-03 22:13:55.000000000 +0200 @@ -12,7 +12,7 @@ -- | Haskell expressions data UExpr dom stage - = UVar { _exprName :: Ann UName dom stage + = UVar { _exprName :: Ann UName dom stage } -- ^ A variable or a data constructor (@ a @) | ULit { _exprLit :: Ann ULiteral dom stage } -- ^ Literal expression (@ 42 @) @@ -116,7 +116,7 @@ | UStaticPtr { _exprInner :: Ann UExpr dom stage } -- ^ Static pointer expression (@ static e @). The inner expression must be closed (cannot have variables bound outside) -- XML expressions omitted - + -- | Field update expressions data UFieldUpdate dom stage = UNormalFieldUpdate { _fieldName :: Ann UName dom stage @@ -126,7 +126,7 @@ } -- ^ Update the field to the value of the same name (@ x @) | UFieldWildcard { _fieldWildcard :: Ann UFieldWildcard dom stage } -- ^ Update the fields of the bounded names to their values (@ .. @). Must be the last initializer. Cannot be used in a record update expression. - + -- | Marker for a field wildcard. Only needed to attach semantic information in a type-safe way. data UFieldWildcard dom stage = FldWildcard @@ -135,7 +135,7 @@ = Present { _tupSecExpr :: Ann UExpr dom stage } -- ^ An existing element in a tuple section | Missing -- ^ A missing element in a tuple section - + -- | Clause of case expression (@ Just x -> x + 1 @) data UAlt' expr dom stage = UAlt { _altPattern :: Ann UPattern dom stage @@ -145,7 +145,7 @@ type UAlt = UAlt' UExpr type UCmdAlt = UAlt' UCmd - + -- | Right hand side of a match (possible with guards): (@ -> 3 @ or @ | x == 1 -> 3; | otherwise -> 4 @) data UCaseRhs' expr dom stage = UUnguardedCaseRhs { _rhsCaseExpr :: Ann expr dom stage @@ -154,15 +154,15 @@ } -- ^ Guarded right-hand sides of a pattern match (@ | x == 1 -> 3; | otherwise -> 4 @) type UCaseRhs = UCaseRhs' UExpr type UCmdCaseRhs = UCaseRhs' UCmd - --- | A guarded right-hand side of pattern matches binding (@ | x > 3 -> 2 @) + +-- | A guarded right-hand side of pattern matches binding (@ | x > 3 -> 2 @) data UGuardedCaseRhs' expr dom stage = UGuardedCaseRhs { _caseGuardStmts :: AnnListG URhsGuard dom stage -- ^ Cannot be empty. , _caseGuardExpr :: Ann expr dom stage - } + } type UGuardedCaseRhs = UGuardedCaseRhs' UExpr type UCmdGuardedCaseRhs = UGuardedCaseRhs' UCmd - + -- | Pragmas that can be applied to expressions data UExprPragma dom stage = UCorePragma { _pragmaStr :: Ann UStringNode dom stage @@ -179,12 +179,12 @@ , _srFromCol :: Ann Number dom stage , _srToLine :: Ann Number dom stage , _srToCol :: Ann Number dom stage - } + } data Number dom stage - = Number { _numberInteger :: Integer + = Number { _numberInteger :: Integer } - + -- * Arrows data UCmd dom stage @@ -204,7 +204,7 @@ } -- ^ An infix command application | ULambdaCmd { _cmdBindings :: AnnListG UPattern dom stage -- ^ at least one , _cmdInner :: Ann UCmd dom stage - } -- ^ A lambda command + } -- ^ A lambda command | UParenCmd { _cmdInner :: Ann UCmd dom stage } -- ^ A parenthesized command | UCaseCmd { _cmdExpr :: Ann UExpr dom stage diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Kinds.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Kinds.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Kinds.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Kinds.hs 2017-05-17 10:56:30.000000000 +0200 @@ -2,13 +2,14 @@ module Language.Haskell.Tools.AST.Representation.Kinds where import Language.Haskell.Tools.AST.Ann (Ann, AnnListG) -import Language.Haskell.Tools.AST.Representation.Names (UName) +import Language.Haskell.Tools.AST.Representation.Names (UName, UOperator) +import {-# SOURCE #-} Language.Haskell.Tools.AST.Representation.Types (UType) -- | Kind constraint (@ :: * -> * @) data UKindConstraint dom stage - = UKindConstraint { _kindConstr :: Ann UKind dom stage + = UKindConstraint { _kindConstr :: Ann UKind dom stage } - + -- | Haskell kinds data UKind dom stage = UStarKind -- ^ @*@, the kind of types @@ -21,22 +22,30 @@ | UVarKind { _kindVar :: Ann UName dom stage } -- ^ Kind variable (using @PolyKinds@ extension) | UAppKind { _kindAppFun :: Ann UKind dom stage - , _kindAppArg :: Ann UKind dom stage + , _kindAppArg :: Ann UKind dom stage } -- ^ Kind application (@ k1 k2 @) + | UInfixAppKind { _kindLhs ::Ann UKind dom stage + , _kindAppOp :: Ann UOperator dom stage + , _kindRhs :: Ann UKind dom stage + } -- ^ Infix kind application (@ k1 ~> k2 @) | UListKind { _kindElem :: Ann UKind dom stage } -- ^ A list kind (@ [k] @) + | UTupleKind { _kindElems :: AnnListG UKind dom stage + } -- ^ A tuple kind (@ (Symbol, *) @) | UPromotedKind { _kindPromoted :: Ann (UPromoted UKind) dom stage } -- ^ A promoted kind (@ '(k1,k2,k3) @) + | UTypeKind { _kindType :: Ann UType dom stage + } -- ^ A type on the kind level with @TypeInType@ data UPromoted t dom stage - = UPromotedInt { _promotedIntValue :: Integer + = UPromotedInt { _promotedIntValue :: Integer } -- ^ Numeric value promoted to the kind level. - | UPromotedString { _promotedStringValue :: String + | UPromotedString { _promotedStringValue :: String } -- ^ String value promoted to the kind level. - | UPromotedCon { _promotedConName :: Ann UName dom stage + | UPromotedCon { _promotedConName :: Ann UName dom stage } -- ^ A data constructor value promoted to the kind level. - | UPromotedList { _promotedElements :: AnnListG t dom stage + | UPromotedList { _promotedElements :: AnnListG t dom stage } -- ^ A list of elements as a kind. - | UPromotedTuple { _promotedElements :: AnnListG t dom stage + | UPromotedTuple { _promotedElements :: AnnListG t dom stage } -- ^ A tuple of elements as a kind. - | UPromotedUnit -- ^ Kind of the unit value @()@. \ No newline at end of file + | UPromotedUnit -- ^ Kind of the unit value @()@. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Names.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Names.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Names.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Names.hs 2017-05-03 22:13:55.000000000 +0200 @@ -6,39 +6,39 @@ -- | Simple AST elements of Haskell module Language.Haskell.Tools.AST.Representation.Names where - + import Language.Haskell.Tools.AST.Ann (Ann, AnnListG(..)) data UOperator dom stage - = UBacktickOp { _operatorName :: Ann UQualifiedName dom stage + = UBacktickOp { _operatorName :: Ann UQualifiedName dom stage } -- ^ A normal name used as an operator with backticks: @ a `mod` b @ - | UNormalOp { _operatorName :: Ann UQualifiedName dom stage + | UNormalOp { _operatorName :: Ann UQualifiedName dom stage } -- ^ A normal operator used as an operator. data UName dom stage - = UParenName { _simpleName :: Ann UQualifiedName dom stage + = UParenName { _simpleName :: Ann UQualifiedName dom stage } -- ^ Parenthesized name: @ foldl (+) 0 @ - | UNormalName { _simpleName :: Ann UQualifiedName dom stage + | UNormalName { _simpleName :: Ann UQualifiedName dom stage } -- ^ A normal, non-operator name. - | UImplicitName { _simpleName :: Ann UQualifiedName dom stage + | UImplicitName { _simpleName :: Ann UQualifiedName dom stage } -- ^ Implicit name: @ ?var @ -- | Possible qualified names. Contains also implicit names. -- Linear implicit parameter: @%x@. Non-linear implicit parameter: @?x@. data UQualifiedName dom stage = UQualifiedName { _qualifiers :: AnnListG UNamePart dom stage - , _unqualifiedName :: Ann UNamePart dom stage - } + , _unqualifiedName :: Ann UNamePart dom stage + } nameFromList :: AnnListG UNamePart dom stage -> UQualifiedName dom stage -nameFromList (AnnListG a xs) | not (null xs) - = UQualifiedName (AnnListG a (init xs)) (last xs) +nameFromList (AnnListG a xs) | not (null xs) + = UQualifiedName (AnnListG a (init xs)) (last xs) nameFromList _ = error "nameFromList: empty list" - --- | Parts of a qualified name. + +-- | Parts of a qualified name. data UNamePart dom stage - = UNamePart { _simpleNameStr :: String } - + = UNamePart { _simpleNameStr :: String } + -- | Program elements formatted as string literals (import packages, pragma texts) data UStringNode dom stage - = UStringNode { _stringNodeStr :: String } + = UStringNode { _stringNodeStr :: String } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Types.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Types.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Types.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Types.hs 2017-05-03 22:13:55.000000000 +0200 @@ -65,10 +65,8 @@ -- One or more assertions data UContext dom stage - = UContextOne { _contextAssertion :: Ann UAssertion dom stage - } -- ^ One assertion (@ C a => ... @) - | UContextMulti { _contextAssertions :: AnnListG UAssertion dom stage - } -- ^ A set of assertions (@ (C1 a, C2 b) => ... @, but can be one: @ (C a) => ... @) + = UContext { _contextAssertion :: Ann UAssertion dom stage + } -- ^ Assertions with the fat arrow (@ C a => ... @) -- | A single assertion in the context data UAssertion dom stage @@ -82,5 +80,6 @@ | UImplicitAssert { _assertImplVar :: Ann UName dom stage , _assertImplType :: Ann UType dom stage } -- ^ Assertion for implicit parameter binding (@ ?cmp :: a -> a -> Bool @) - - \ No newline at end of file + | UTupleAssert { _innerAsserts :: AnnListG UAssertion dom stage + } -- ^ Multiple assertions in one (@ (Ord a, Show a) @) + | UWildcardAssert -- ^ Wildcard assertion (@ _ @), enabled by @PartialTypeSignatures@ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Types.hs-boot new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Types.hs-boot --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Representation/Types.hs-boot 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Representation/Types.hs-boot 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,6 @@ +{-# LANGUAGE RoleAnnotations #-} +-- | Representation of Haskell types +module Language.Haskell.Tools.AST.Representation.Types where + +type role UType nominal nominal +data UType dom stage diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/SemaInfoClasses.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/SemaInfoClasses.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/SemaInfoClasses.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/SemaInfoClasses.hs 2017-05-22 15:12:54.000000000 +0200 @@ -4,7 +4,7 @@ , TypeFamilies , UndecidableInstances #-} -module Language.Haskell.Tools.AST.SemaInfoClasses where +module Language.Haskell.Tools.AST.SemaInfoClasses (module Language.Haskell.Tools.AST.SemaInfoClasses, UsageSpec(..)) where import GHC import Id as GHC (Id, idName) @@ -33,7 +33,7 @@ semanticsName = fmap idName . (^? cnameInfo) instance HasNameInfo dom => HasNameInfo' (Ann UQualifiedName dom st) where - semanticsName = semanticsName . (^. annotation&semanticInfo) + semanticsName = semanticsName . (^. annotation&semanticInfo) -- * Information about typed names @@ -47,7 +47,7 @@ semanticsId = (^. cnameInfo) instance HasIdInfo dom => HasIdInfo' (Ann UQualifiedName dom st) where - semanticsId = semanticsId . (^. annotation&semanticInfo) + semanticsId = semanticsId . (^. annotation&semanticInfo) -- * Fixity information @@ -61,7 +61,7 @@ semanticsFixity = (^. cnameFixity) instance HasFixityInfo dom => HasFixityInfo' (Ann UQualifiedName dom st) where - semanticsFixity = semanticsFixity . (^. annotation&semanticInfo) + semanticsFixity = semanticsFixity . (^. annotation&semanticInfo) -- * Scope information @@ -81,10 +81,10 @@ semanticsScope = (^. exprScopedLocals) instance HasScopeInfo dom => HasScopeInfo' (Ann UExpr dom st) where - semanticsScope = semanticsScope . (^. annotation&semanticInfo) + semanticsScope = semanticsScope . (^. annotation&semanticInfo) instance HasScopeInfo dom => HasScopeInfo' (Ann UQualifiedName dom st) where - semanticsScope = semanticsScope . (^. annotation&semanticInfo) + semanticsScope = semanticsScope . (^. annotation&semanticInfo) -- * Information about names being defined @@ -101,7 +101,7 @@ semanticsDefining = (^. cnameIsDefined) instance HasDefiningInfo dom => HasDefiningInfo' (Ann UQualifiedName dom st) where - semanticsDefining = semanticsDefining . (^. annotation&semanticInfo) + semanticsDefining = semanticsDefining . (^. annotation&semanticInfo) -- * Information about source info in sema @@ -117,6 +117,7 @@ class HasModuleInfo' si where semanticsModule :: si -> GHC.Module + semanticsDynFlags :: si -> GHC.DynFlags isBootModule :: si -> Bool semanticsImplicitImports :: si -> [GHC.Name] semanticsPrelOrphanInsts :: si -> [ClsInst] @@ -124,6 +125,7 @@ instance HasModuleInfo' (AST.ModuleInfo GHC.Name) where semanticsModule = (^. defModuleName) + semanticsDynFlags = (^. defDynFlags) isBootModule = (^. defIsBootModule) semanticsImplicitImports = (^. implicitNames) semanticsPrelOrphanInsts = (^. prelOrphanInsts) @@ -131,22 +133,24 @@ instance HasModuleInfo' (AST.ModuleInfo GHC.Id) where semanticsModule = (^. defModuleName) + semanticsDynFlags = (^. defDynFlags) isBootModule = (^. defIsBootModule) semanticsImplicitImports = map idName . (^. implicitNames) semanticsPrelOrphanInsts = (^. prelOrphanInsts) semanticsPrelFamInsts = (^. prelFamInsts) instance HasModuleInfo dom => HasModuleInfo' (Ann UModule dom st) where - semanticsModule = semanticsModule . (^. annotation&semanticInfo) - isBootModule = isBootModule . (^. annotation&semanticInfo) - semanticsImplicitImports = semanticsImplicitImports . (^. annotation&semanticInfo) - semanticsPrelOrphanInsts = semanticsPrelOrphanInsts . (^. annotation&semanticInfo) - semanticsPrelFamInsts = semanticsPrelFamInsts . (^. annotation&semanticInfo) + semanticsModule = semanticsModule . (^. annotation&semanticInfo) + semanticsDynFlags = semanticsDynFlags . (^. annotation&semanticInfo) + isBootModule = isBootModule . (^. annotation&semanticInfo) + semanticsImplicitImports = semanticsImplicitImports . (^. annotation&semanticInfo) + semanticsPrelOrphanInsts = semanticsPrelOrphanInsts . (^. annotation&semanticInfo) + semanticsPrelFamInsts = semanticsPrelFamInsts . (^. annotation&semanticInfo) -- * Information about imports type HasImportInfo dom = (Domain dom, HasImportInfo' (SemanticInfo dom AST.UImportDecl)) - + class HasImportInfo' si where semanticsImportedModule :: si -> GHC.Module semanticsAvailable :: si -> [GHC.Name] @@ -169,16 +173,16 @@ semanticsFamInsts = (^. importedFamInsts) instance HasImportInfo dom => HasImportInfo' (Ann UImportDecl dom st) where - semanticsImportedModule = semanticsImportedModule . (^. annotation&semanticInfo) - semanticsAvailable = semanticsAvailable . (^. annotation&semanticInfo) - semanticsImported = semanticsImported . (^. annotation&semanticInfo) - semanticsOrphanInsts = semanticsOrphanInsts . (^. annotation&semanticInfo) - semanticsFamInsts = semanticsFamInsts . (^. annotation&semanticInfo) + semanticsImportedModule = semanticsImportedModule . (^. annotation&semanticInfo) + semanticsAvailable = semanticsAvailable . (^. annotation&semanticInfo) + semanticsImported = semanticsImported . (^. annotation&semanticInfo) + semanticsOrphanInsts = semanticsOrphanInsts . (^. annotation&semanticInfo) + semanticsFamInsts = semanticsFamInsts . (^. annotation&semanticInfo) --- * Information about implicitely bounded fields +-- * Information about implicitly bounded fields type HasImplicitFieldsInfo dom = (Domain dom, HasImplicitFieldsInfo' (SemanticInfo dom AST.UFieldWildcard)) - + class HasImplicitFieldsInfo' si where semanticsImplicitFlds :: si -> [(GHC.Name, GHC.Name)] @@ -186,7 +190,7 @@ semanticsImplicitFlds = (^. implicitFieldBindings) instance HasImplicitFieldsInfo dom => HasImplicitFieldsInfo' (Ann UFieldWildcard dom st) where - semanticsImplicitFlds = semanticsImplicitFlds . (^. annotation&semanticInfo) + semanticsImplicitFlds = semanticsImplicitFlds . (^. annotation&semanticInfo) -- * AST elements with no information diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/SemaInfoTypes.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/SemaInfoTypes.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/SemaInfoTypes.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/SemaInfoTypes.hs 2017-05-22 15:12:54.000000000 +0200 @@ -1,18 +1,18 @@ {-# LANGUAGE DeriveDataTypeable - , StandaloneDeriving - , TemplateHaskell + , StandaloneDeriving + , TemplateHaskell , UndecidableInstances , FlexibleContexts , FlexibleInstances #-} module Language.Haskell.Tools.AST.SemaInfoTypes - ( -- types + ( -- types NoSemanticInfo, ScopeInfo, NameInfo, CNameInfo, ModuleInfo, ImportInfo, ImplicitFieldInfo - , Scope + , Scope, UsageSpec(..) -- references , exprScopedLocals, nameScopedLocals, nameIsDefined, nameInfo, ambiguousName, nameLocation , implicitName, cnameScopedLocals, cnameIsDefined, cnameInfo, cnameFixity - , defModuleName, defIsBootModule, implicitNames, importedModule, availableNames, importedNames + , defModuleName, defDynFlags, defIsBootModule, implicitNames, importedModule, availableNames, importedNames , implicitFieldBindings, importedOrphanInsts, importedFamInsts, prelOrphanInsts, prelFamInsts -- creator functions , mkNoSemanticInfo, mkScopeInfo, mkNameInfo, mkAmbiguousNameInfo, mkImplicitNameInfo, mkCNameInfo @@ -20,6 +20,7 @@ ) where import BasicTypes as GHC +import DynFlags as GHC import FamInstEnv as GHC import Id as GHC import InstEnv as GHC @@ -34,18 +35,30 @@ import Control.Reference -type Scope = [[Name]] +type Scope = [[(Name, Maybe [UsageSpec])]] --- | Semantic info type for any node not +data UsageSpec = UsageSpec { usageQualified :: Bool + , usageQualifier :: String + , usageAs :: String + } + deriving (Eq, Data) + +instance Outputable UsageSpec where + ppr (UsageSpec q useQ asQ) + = GHC.text $ (if q then "qualified " else "") ++ "as " ++ (if useQ == asQ || q then asQ else asQ ++ " or " ++ useQ) + pprPrec _ (UsageSpec q useQ asQ) + = GHC.text $ (if q then "qualified " else "") ++ "as " ++ (if useQ == asQ || q then asQ else asQ ++ " or " ++ useQ) + +-- | Semantic info type for any node not -- carrying additional semantic information -data NoSemanticInfo = NoSemanticInfo +data NoSemanticInfo = NoSemanticInfo deriving (Eq, Data) mkNoSemanticInfo :: NoSemanticInfo mkNoSemanticInfo = NoSemanticInfo -- | Info for expressions that tells which definitions are in scope -data ScopeInfo = ScopeInfo { _exprScopedLocals :: Scope +data ScopeInfo = ScopeInfo { _exprScopedLocals :: Scope } deriving (Eq, Data) @@ -57,7 +70,7 @@ data NameInfo n = NameInfo { _nameScopedLocals :: Scope , _nameIsDefined :: Bool , _nameInfo :: n - } + } | AmbiguousNameInfo { _nameScopedLocals :: Scope , _nameIsDefined :: Bool , _ambiguousName :: RdrName @@ -96,24 +109,33 @@ mkCNameInfo = CNameInfo -- | Info for the module element -data ModuleInfo n = ModuleInfo { _defModuleName :: GHC.Module +data ModuleInfo n = ModuleInfo { _defModuleName :: GHC.Module + , _defDynFlags :: DynFlags -- ^ The compilation flags that are set up when the module was compiled , _defIsBootModule :: Bool -- ^ True if this module is created from a hs-boot file - , _implicitNames :: [n] -- ^ Implicitely imported names - , _prelOrphanInsts :: [ClsInst] -- ^ Class instances implicitely passed from Prelude. - , _prelFamInsts :: [FamInst] -- ^ Family instances implicitely passed from Prelude. - } + , _implicitNames :: [n] -- ^ implicitly imported names + , _prelOrphanInsts :: [ClsInst] -- ^ Class instances implicitly passed from Prelude. + , _prelFamInsts :: [FamInst] -- ^ Family instances implicitly passed from Prelude. + } deriving Data +instance Data DynFlags where + gunfold k z c = error "Cannot construct dyn flags" + toConstr _ = dynFlagsCon + dataTypeOf _ = dynFlagsType + +dynFlagsType = mkDataType "DynFlags.DynFlags" [dynFlagsCon] +dynFlagsCon = mkConstr dynFlagsType "DynFlags" [] Prefix + -- | Creates semantic information for the module element -mkModuleInfo :: GHC.Module -> Bool -> [n] -> [ClsInst] -> [FamInst] -> ModuleInfo n +mkModuleInfo :: GHC.Module -> DynFlags -> Bool -> [n] -> [ClsInst] -> [FamInst] -> ModuleInfo n mkModuleInfo = ModuleInfo -- | Info corresponding to an import declaration data ImportInfo n = ImportInfo { _importedModule :: GHC.Module -- ^ The name and package of the imported module , _availableNames :: [n] -- ^ Names available from the imported module , _importedNames :: [n] -- ^ Names actually imported from the module. - , _importedOrphanInsts :: [ClsInst] -- ^ Class instances implicitely passed. - , _importedFamInsts :: [FamInst] -- ^ Family instances implicitely passed. + , _importedOrphanInsts :: [ClsInst] -- ^ Class instances implicitly passed. + , _importedFamInsts :: [FamInst] -- ^ Family instances implicitly passed. } deriving Data @@ -125,8 +147,8 @@ mkImportInfo = ImportInfo -- | Info corresponding to an record-wildcard -data ImplicitFieldInfo = ImplicitFieldInfo { _implicitFieldBindings :: [(Name, Name)] -- ^ The implicitely bounded names - } +data ImplicitFieldInfo = ImplicitFieldInfo { _implicitFieldBindings :: [(Name, Name)] -- ^ The implicitly bounded names + } deriving (Eq, Data) -- | Creates semantic information for a wildcard field binding @@ -145,13 +167,13 @@ show (CNameInfo locals defined nameInfo fixity) = "(CNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " " ++ showSDocUnsafe (ppr nameInfo) ++ showSDocUnsafe (ppr fixity) ++ ")" instance Outputable n => Show (ModuleInfo n) where - show (ModuleInfo mod isboot imp clsInsts famInsts) - = "(ModuleInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ show isboot ++ " " ++ showSDocUnsafe (ppr imp) ++ " " + show (ModuleInfo mod _ isboot imp clsInsts famInsts) + = "(ModuleInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ show isboot ++ " " ++ showSDocUnsafe (ppr imp) ++ " " ++ showSDocUnsafe (ppr clsInsts) ++ " " ++ showSDocUnsafe (ppr famInsts) ++ ")" instance Outputable n => Show (ImportInfo n) where - show (ImportInfo mod avail imported clsInsts famInsts) - = "(ImportInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ showSDocUnsafe (ppr avail) ++ " " ++ showSDocUnsafe (ppr imported) ++ " " + show (ImportInfo mod avail imported clsInsts famInsts) + = "(ImportInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ showSDocUnsafe (ppr avail) ++ " " ++ showSDocUnsafe (ppr imported) ++ " " ++ showSDocUnsafe (ppr clsInsts) ++ " " ++ showSDocUnsafe (ppr famInsts) ++ ")" instance Show ImplicitFieldInfo where @@ -192,10 +214,9 @@ traverse _ (ImplicitNameInfo locals defined nameInfo span) = pure $ ImplicitNameInfo locals defined nameInfo span instance Traversable ModuleInfo where - traverse f (ModuleInfo mod isboot imp clsInsts famInsts) - = ModuleInfo mod isboot <$> traverse f imp <*> pure clsInsts <*> pure famInsts + traverse f (ModuleInfo mod dfs isboot imp clsInsts famInsts) + = ModuleInfo mod dfs isboot <$> traverse f imp <*> pure clsInsts <*> pure famInsts instance Traversable ImportInfo where - traverse f (ImportInfo mod avail imps clsInsts famInsts) + traverse f (ImportInfo mod avail imps clsInsts famInsts) = ImportInfo mod <$> traverse f avail <*> traverse f imps <*> pure clsInsts <*> pure famInsts - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Utils/OrdSrcSpan.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Utils/OrdSrcSpan.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST/Utils/OrdSrcSpan.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST/Utils/OrdSrcSpan.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,30 +0,0 @@ --- | A wrapper for SrcSpans that is ordered. -module Language.Haskell.Tools.AST.Utils.OrdSrcSpan where - -import FastString (FastString) -import SrcLoc - --- | Wraps the SrcSpan into an ordered source span -ordSrcSpan :: SrcSpan -> OrdSrcSpan -ordSrcSpan (RealSrcSpan sp) = OrdSrcSpan sp -ordSrcSpan (UnhelpfulSpan fs) = NoOrdSrcSpan fs - --- | Unwrap the ordered source span -fromOrdSrcSpan :: OrdSrcSpan -> SrcSpan -fromOrdSrcSpan (OrdSrcSpan sp) = RealSrcSpan sp -fromOrdSrcSpan (NoOrdSrcSpan fs) = UnhelpfulSpan fs - --- | A wrapper for SrcSpans that is ordered. -data OrdSrcSpan - = OrdSrcSpan RealSrcSpan - | NoOrdSrcSpan FastString - deriving (Show, Eq) - -instance Ord OrdSrcSpan where - compare (NoOrdSrcSpan _) (NoOrdSrcSpan _) = EQ - compare (OrdSrcSpan _) (NoOrdSrcSpan _) = GT - compare (NoOrdSrcSpan _) (OrdSrcSpan _) = LT - compare (OrdSrcSpan rsp1) (OrdSrcSpan rsp2) - = compare (realSrcSpanStart rsp1) (realSrcSpanStart rsp2) - `mappend` compare (realSrcSpanEnd rsp1) (realSrcSpanEnd rsp2) - \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST.hs new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST.hs --- old/haskell-tools-ast-0.5.0.0/Language/Haskell/Tools/AST.hs 2017-01-31 20:47:39.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/Language/Haskell/Tools/AST.hs 2017-05-03 22:13:55.000000000 +0200 @@ -1,7 +1,7 @@ -- | A custom AST representation for Haskell tools. -- Different layers of the AST are recursive, to separate them into modules -- we introduced source imports. -module Language.Haskell.Tools.AST +module Language.Haskell.Tools.AST ( module Language.Haskell.Tools.AST.References , module Language.Haskell.Tools.AST.Helpers , module Language.Haskell.Tools.AST.Representation.Modules @@ -16,7 +16,6 @@ , module Language.Haskell.Tools.AST.Representation.Literals , module Language.Haskell.Tools.AST.Representation.Names , module Language.Haskell.Tools.AST.Ann - , module Language.Haskell.Tools.AST.Utils.OrdSrcSpan , module Language.Haskell.Tools.AST.SemaInfoClasses ) where @@ -37,4 +36,3 @@ import Language.Haskell.Tools.AST.Representation.TH import Language.Haskell.Tools.AST.Representation.Types import Language.Haskell.Tools.AST.SemaInfoClasses -import Language.Haskell.Tools.AST.Utils.OrdSrcSpan diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-ast-0.5.0.0/haskell-tools-ast.cabal new/haskell-tools-ast-0.8.0.0/haskell-tools-ast.cabal --- old/haskell-tools-ast-0.5.0.0/haskell-tools-ast.cabal 2017-01-31 20:57:34.000000000 +0100 +++ new/haskell-tools-ast-0.8.0.0/haskell-tools-ast.cabal 2017-07-01 12:34:40.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-ast -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Haskell AST for efficient tooling description: A representation of a Haskell Syntax tree that contain source-related and semantic annotations. These annotations help developer tools to work with the defined program. The source information enables refactoring and program transformation tools to change the source code without losing the original format (layout, comments) of the source. Semantic information helps analyzing the program. The representation is different from the GHC's syntax tree. It contains information from all representations in GHC (different version of syntax trees, lexical and module-level information). The module is split up to put the representation of different language elements into different modules. Additionally, it contains the representation of semantic and source annotations, helper functions and generated instances for the representation of language elements. Because langauge elements may refer each other (there can be a pattern inside an expression in case of a pattern match and an expression inside a pattern if view patterns are enabled), we use hs-boot files to break up dependency cycles. @@ -13,13 +13,13 @@ cabal-version: >=1.10 library - ghc-options: -O2 + ghc-options: -O2 exposed-modules: Language.Haskell.Tools.AST , Language.Haskell.Tools.AST.References , Language.Haskell.Tools.AST.Helpers , Language.Haskell.Tools.AST.Ann , Language.Haskell.Tools.AST.SemaInfoTypes - , Language.Haskell.Tools.AST.SemaInfoClasses + , Language.Haskell.Tools.AST.SemaInfoClasses other-modules: Language.Haskell.Tools.AST.Representation.Modules , Language.Haskell.Tools.AST.Representation.TH @@ -34,7 +34,6 @@ , Language.Haskell.Tools.AST.Representation.Names , Language.Haskell.Tools.AST.MakeASTReferences - , Language.Haskell.Tools.AST.Utils.OrdSrcSpan , Language.Haskell.Tools.AST.Utils.GHCInstances , Language.Haskell.Tools.AST.Instances @@ -46,11 +45,11 @@ , Language.Haskell.Tools.AST.Instances.SourceInfoTraversal , Language.Haskell.Tools.AST.TH.SemanticTraversal , Language.Haskell.Tools.AST.TH.SourceInfoTraversal - + build-depends: base >= 4.9 && < 4.10 , ghc >= 8.0 && < 8.1 , references >= 0.3 && < 0.4 , uniplate >= 1.6 && < 1.7 , mtl >= 2.2 && < 2.3 , template-haskell >= 2.11 && < 2.12 - default-language: Haskell2010 \ No newline at end of file + default-language: Haskell2010

1 0

commit ghc-happstack-server-tls for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-happstack-server-tls for openSUSE:Factory checked in at 2017-08-31 20:55:50 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-happstack-server-tls (Old) and /work/SRC/openSUSE:Factory/.ghc-happstack-server-tls.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-happstack-server-tls" Thu Aug 31 20:55:50 2017 rev:2 rq:513365 version:7.1.6.3 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-happstack-server-tls/ghc-happstack-server-tls.changes 2017-04-14 13:32:30.851543260 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-happstack-server-tls.new/ghc-happstack-server-tls.changes 2017-08-31 20:55:50.612642850 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:02:51 UTC 2017 - psimons(a)suse.com + +- Update to version 7.1.6.3. + +------------------------------------------------------------------- Old: ---- happstack-server-tls-7.1.6.2.tar.gz New: ---- happstack-server-tls-7.1.6.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-happstack-server-tls.spec ++++++ --- /var/tmp/diff_new_pack.irGNi7/_old 2017-08-31 20:55:51.752482699 +0200 +++ /var/tmp/diff_new_pack.irGNi7/_new 2017-08-31 20:55:51.776479327 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-happstack-server-tls # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -18,15 +18,14 @@ %global pkg_name happstack-server-tls Name: ghc-%{pkg_name} -Version: 7.1.6.2 +Version: 7.1.6.3 Release: 0 Summary: Extend happstack-server with https:// support (TLS/SSL) License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-HsOpenSSL-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-extensible-exceptions-devel @@ -39,7 +38,6 @@ BuildRequires: ghc-unix-devel BuildRequires: libopenssl-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build -# End cabal-rpm deps %description Extend happstack-server with https:// support (TLS/SSL). @@ -49,11 +47,9 @@ Group: Development/Libraries/Other Requires: %{name} = %{version}-%{release} Requires: ghc-compiler = %{ghc_version} -# Begin cabal-rpm deps: Requires: libopenssl-devel Requires(post): ghc-compiler = %{ghc_version} Requires(postun): ghc-compiler = %{ghc_version} -# End cabal-rpm deps %description devel This package provides the Haskell %{pkg_name} library development @@ -62,15 +58,12 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %post devel %ghc_pkg_recache ++++++ happstack-server-tls-7.1.6.2.tar.gz -> happstack-server-tls-7.1.6.3.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happstack-server-tls-7.1.6.2/happstack-server-tls.cabal new/happstack-server-tls-7.1.6.3/happstack-server-tls.cabal --- old/happstack-server-tls-7.1.6.2/happstack-server-tls.cabal 2016-06-05 23:03:09.000000000 +0200 +++ new/happstack-server-tls-7.1.6.3/happstack-server-tls.cabal 2017-07-21 20:14:51.000000000 +0200 @@ -1,5 +1,5 @@ Name: happstack-server-tls -Version: 7.1.6.2 +Version: 7.1.6.3 Synopsis: extend happstack-server with https:// support (TLS/SSL) Description: extend happstack-server with https:// support (TLS/SSL) Homepage: http://www.happstack.com/ @@ -10,7 +10,7 @@ Copyright: 2012 Jeremy Shaw Category: Web, Happstack Build-type: Simple -Cabal-version: >=1.6 +Cabal-version: >=1.10 tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 extra-source-files: README.md @@ -19,6 +19,7 @@ location: https://github.com/Happstack/happstack-server-tls.git Library + Default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-do-bind Exposed-modules: Happstack.Server.Internal.TimeoutSocketTLS @@ -28,7 +29,7 @@ Build-Depends: base < 5, bytestring >= 0.9 && < 0.11, extensible-exceptions == 0.1.*, - happstack-server >= 6.6.4 && < 7.5, + happstack-server >= 6.6.4 && < 7.6, hslogger >= 1.1 && < 1.3, HsOpenSSL >= 0.10 && < 0.12, network >= 2.3 && < 2.7,

1 0

commit ghc-happstack-jmacro for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-happstack-jmacro for openSUSE:Factory checked in at 2017-08-31 20:55:47 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-happstack-jmacro (Old) and /work/SRC/openSUSE:Factory/.ghc-happstack-jmacro.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-happstack-jmacro" Thu Aug 31 20:55:47 2017 rev:2 rq:513364 version:7.0.12 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-happstack-jmacro/ghc-happstack-jmacro.changes 2017-05-16 14:39:58.102856078 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-happstack-jmacro.new/ghc-happstack-jmacro.changes 2017-08-31 20:55:49.508797945 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:46 UTC 2017 - psimons(a)suse.com + +- Update to version 7.0.12. + +------------------------------------------------------------------- Old: ---- happstack-jmacro-7.0.11.tar.gz New: ---- happstack-jmacro-7.0.12.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-happstack-jmacro.spec ++++++ --- /var/tmp/diff_new_pack.rPgpcw/_old 2017-08-31 20:55:50.304686120 +0200 +++ /var/tmp/diff_new_pack.rPgpcw/_new 2017-08-31 20:55:50.312684996 +0200 @@ -18,7 +18,7 @@ %global pkg_name happstack-jmacro Name: ghc-%{pkg_name} -Version: 7.0.11 +Version: 7.0.12 Release: 0 Summary: Support for using JMacro with Happstack License: BSD-3-Clause ++++++ happstack-jmacro-7.0.11.tar.gz -> happstack-jmacro-7.0.12.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happstack-jmacro-7.0.11/happstack-jmacro.cabal new/happstack-jmacro-7.0.12/happstack-jmacro.cabal --- old/happstack-jmacro-7.0.11/happstack-jmacro.cabal 2015-12-01 00:28:14.000000000 +0100 +++ new/happstack-jmacro-7.0.12/happstack-jmacro.cabal 2017-07-21 20:01:40.000000000 +0200 @@ -1,6 +1,7 @@ Name: happstack-jmacro -Version: 7.0.11 +Version: 7.0.12 Synopsis: Support for using JMacro with Happstack +Description: Support for using JMacro with Happstack Homepage: http://www.happstack.com/ License: BSD3 License-file: LICENSE @@ -11,6 +12,7 @@ Category: Web, Happstack Build-type: Simple Cabal-version: >=1.6 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Library Exposed-modules: Happstack.Server.JMacro @@ -20,7 +22,7 @@ bytestring >= 0.9 && < 0.11, cereal >= 0.3 && < 0.6, digest == 0.0.*, - happstack-server >= 6.4 && < 7.5, + happstack-server >= 6.4 && < 7.6, jmacro == 0.6.*, wl-pprint-text == 1.1.*, text >= 0.9 && < 1.3,

1 0

commit ghc-happstack-hsp for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-happstack-hsp for openSUSE:Factory checked in at 2017-08-31 20:55:45 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-happstack-hsp (Old) and /work/SRC/openSUSE:Factory/.ghc-happstack-hsp.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-happstack-hsp" Thu Aug 31 20:55:45 2017 rev:2 rq:513363 version:7.3.7.3 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-happstack-hsp/ghc-happstack-hsp.changes 2017-05-16 14:39:55.535216834 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-happstack-hsp.new/ghc-happstack-hsp.changes 2017-08-31 20:55:47.689053625 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:04:31 UTC 2017 - psimons(a)suse.com + +- Update to version 7.3.7.3. + +------------------------------------------------------------------- Old: ---- happstack-hsp-7.3.7.2.tar.gz New: ---- happstack-hsp-7.3.7.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-happstack-hsp.spec ++++++ --- /var/tmp/diff_new_pack.224jjU/_old 2017-08-31 20:55:48.872887292 +0200 +++ /var/tmp/diff_new_pack.224jjU/_new 2017-08-31 20:55:48.892884482 +0200 @@ -18,7 +18,7 @@ %global pkg_name happstack-hsp Name: ghc-%{pkg_name} -Version: 7.3.7.2 +Version: 7.3.7.3 Release: 0 Summary: Support for using HSP templates in Happstack License: BSD-3-Clause ++++++ happstack-hsp-7.3.7.2.tar.gz -> happstack-hsp-7.3.7.3.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happstack-hsp-7.3.7.2/happstack-hsp.cabal new/happstack-hsp-7.3.7.3/happstack-hsp.cabal --- old/happstack-hsp-7.3.7.2/happstack-hsp.cabal 2017-03-08 23:00:18.000000000 +0100 +++ new/happstack-hsp-7.3.7.3/happstack-hsp.cabal 2017-07-21 20:03:23.000000000 +0200 @@ -1,5 +1,5 @@ Name: happstack-hsp -Version: 7.3.7.2 +Version: 7.3.7.3 Synopsis: Support for using HSP templates in Happstack Description: Happstack is a web application framework. HSP is an XML templating solution. This package makes it easy to use HSP templates with Happstack. Homepage: http://www.happstack.com/ @@ -27,7 +27,7 @@ Build-depends: base >= 3.0 && < 5.0, bytestring >= 0.9 && < 0.11, - happstack-server >= 6.0 && < 7.5, + happstack-server >= 6.0 && < 7.6, harp >= 0.4 && < 0.5, hsp >= 0.9.2 && < 0.11, hsx2hs >= 0.13.0 && < 0.15,

1 0

commit ghc-hakyll for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-hakyll for openSUSE:Factory checked in at 2017-08-31 20:55:42 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hakyll (Old) and /work/SRC/openSUSE:Factory/.ghc-hakyll.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-hakyll" Thu Aug 31 20:55:42 2017 rev:3 rq:513361 version:4.9.8.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hakyll/ghc-hakyll.changes 2017-06-21 13:55:28.733866007 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hakyll.new/ghc-hakyll.changes 2017-08-31 20:55:45.349382357 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:38 UTC 2017 - psimons(a)suse.com + +- Update to version 4.9.8.0. + +------------------------------------------------------------------- Old: ---- hakyll-4.9.7.0.tar.gz New: ---- hakyll-4.9.8.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hakyll.spec ++++++ --- /var/tmp/diff_new_pack.TPUyFx/_old 2017-08-31 20:55:46.553213214 +0200 +++ /var/tmp/diff_new_pack.TPUyFx/_new 2017-08-31 20:55:46.557212653 +0200 @@ -20,13 +20,14 @@ %global pkg_name hakyll %bcond_with tests Name: ghc-%{pkg_name} -Version: 4.9.7.0 +Version: 4.9.8.0 Release: 0 Summary: A static website compiler library License: BSD-3-Clause Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… +BuildRequires: chrpath BuildRequires: ghc-Cabal-devel BuildRequires: ghc-binary-devel BuildRequires: ghc-blaze-html-devel @@ -111,6 +112,7 @@ %install %ghc_lib_install +%ghc_fix_rpath %{pkg_name}-%{version} %check %cabal_test ++++++ hakyll-4.9.7.0.tar.gz -> hakyll-4.9.8.0.tar.gz ++++++ ++++ 14848 lines of diff (skipped)

1 0

commit ghc-hackernews for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-hackernews for openSUSE:Factory checked in at 2017-08-31 20:55:37 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hackernews (Old) and /work/SRC/openSUSE:Factory/.ghc-hackernews.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-hackernews" Thu Aug 31 20:55:37 2017 rev:4 rq:513360 version:1.2.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hackernews/ghc-hackernews.changes 2017-07-11 08:25:31.394173810 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hackernews.new/ghc-hackernews.changes 2017-08-31 20:55:42.329806618 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:11 UTC 2017 - psimons(a)suse.com + +- Update to version 1.2.0.0. + +------------------------------------------------------------------- Old: ---- hackernews-1.1.2.0.tar.gz New: ---- hackernews-1.2.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hackernews.spec ++++++ --- /var/tmp/diff_new_pack.j2qFPq/_old 2017-08-31 20:55:44.717471143 +0200 +++ /var/tmp/diff_new_pack.j2qFPq/_new 2017-08-31 20:55:44.721470581 +0200 @@ -19,7 +19,7 @@ %global pkg_name hackernews %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.1.2.0 +Version: 1.2.0.0 Release: 0 Summary: API for Hacker News License: MIT ++++++ hackernews-1.1.2.0.tar.gz -> hackernews-1.2.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackernews-1.1.2.0/ghc-src/Web/HackerNews.hs new/hackernews-1.2.0.0/ghc-src/Web/HackerNews.hs --- old/hackernews-1.1.2.0/ghc-src/Web/HackerNews.hs 2017-05-25 07:43:53.000000000 +0200 +++ new/hackernews-1.2.0.0/ghc-src/Web/HackerNews.hs 2017-06-01 22:26:38.000000000 +0200 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -118,7 +119,11 @@ toError = first go where go :: ServantError -> HackerNewsError +#if MIN_VERSION_servant_client(0,11,0) + go (FailureResponse _ Status{..} _ body) = +#else go (FailureResponse Status{..} _ body) = +#endif FailureResponseError statusCode (cs statusMessage) (cs body) go (DecodeFailure _ _ "null") = NotFound go (DecodeFailure err _ body) = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackernews-1.1.2.0/hackernews.cabal new/hackernews-1.2.0.0/hackernews.cabal --- old/hackernews-1.1.2.0/hackernews.cabal 2017-05-25 07:43:53.000000000 +0200 +++ new/hackernews-1.2.0.0/hackernews.cabal 2017-06-01 22:26:38.000000000 +0200 @@ -1,5 +1,5 @@ name: hackernews -version: 1.1.2.0 +version: 1.2.0.0 description: API for news.ycombinator.com license: MIT synopsis: API for Hacker News @@ -23,13 +23,13 @@ if impl (ghcjs) build-depends: base - , hackernews == 1.1.* + , hackernews == 1.2.* , ghcjs-base hs-source-dirs: ghcjs-examples else build-depends: base - , hackernews == 1.1.* + , hackernews == 1.2.* , http-client-tls , http-client hs-source-dirs: ghc-examples @@ -39,7 +39,7 @@ if impl(ghcjs) hs-source-dirs: ghcjs-tests build-depends: base - , hackernews == 1.1.* + , hackernews == 1.2.* , ghcjs-base , hspec , hspec-core @@ -55,7 +55,7 @@ , Web.HackerNews.Types hs-source-dirs: src build-depends: - servant >= 0.9 && < 0.11 + servant >= 0.9 && < 0.12 , QuickCheck , quickcheck-instances if impl(ghcjs) @@ -72,7 +72,7 @@ hs-source-dirs: ghc-src build-depends: aeson , base < 5 - , servant-client >= 0.9 && < 0.11 + , servant-client >= 0.9 && < 0.12 , http-client == 0.5.* , string-conversions == 0.4.* , http-types == 0.9.* @@ -89,7 +89,7 @@ hs-source-dirs: ghc-tests build-depends: aeson , base - , hackernews == 1.1.* + , hackernews == 1.2.* , hspec , http-client-tls , http-client

1 0

commit ghc-google-translate for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-google-translate for openSUSE:Factory checked in at 2017-08-31 20:55:35 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-google-translate (Old) and /work/SRC/openSUSE:Factory/.ghc-google-translate.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-google-translate" Thu Aug 31 20:55:35 2017 rev:2 rq:513359 version:0.4.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-google-translate/ghc-google-translate.changes 2017-05-10 20:54:44.435092006 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-google-translate.new/ghc-google-translate.changes 2017-08-31 20:55:36.722594451 +0200 @@ -1,0 +2,10 @@ +Sat Jul 29 03:02:12 UTC 2017 - psimons(a)suse.com + +- Update to version 0.4.1. + +------------------------------------------------------------------- +Fri Jul 28 09:43:11 UTC 2017 - psimons(a)suse.com + +- Update to version 0.4. + +------------------------------------------------------------------- Old: ---- google-translate-0.3.tar.gz New: ---- google-translate-0.4.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-google-translate.spec ++++++ --- /var/tmp/diff_new_pack.GUE68h/_old 2017-08-31 20:55:37.838437671 +0200 +++ /var/tmp/diff_new_pack.GUE68h/_new 2017-08-31 20:55:37.842437109 +0200 @@ -18,7 +18,7 @@ %global pkg_name google-translate Name: ghc-%{pkg_name} -Version: 0.3 +Version: 0.4.1 Release: 0 Summary: Google Translate API bindings License: BSD-2-Clause ++++++ google-translate-0.3.tar.gz -> google-translate-0.4.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/google-translate-0.3/google-translate.cabal new/google-translate-0.4.1/google-translate.cabal --- old/google-translate-0.3/google-translate.cabal 2016-10-18 22:04:59.000000000 +0200 +++ new/google-translate-0.4.1/google-translate.cabal 2017-07-29 03:33:36.000000000 +0200 @@ -1,5 +1,5 @@ name: google-translate -version: 0.3 +version: 0.4.1 synopsis: Google Translate API bindings license: BSD3 license-file: LICENSE @@ -16,7 +16,7 @@ library exposed-modules: Web.Google.Translate - ghc-options: -Wall + ghc-options: -Wall hs-source-dirs: src build-depends: aeson , base >= 4.7 && < 5 @@ -24,8 +24,8 @@ , transformers >= 0.4 && < 0.6 , http-api-data >= 0.2 && < 0.4 , http-client >= 0.4 && < 0.6 - , servant >= 0.7 && < 0.10 - , servant-client >= 0.7 && < 0.10 + , servant >= 0.7 && < 0.12 + , servant-client >= 0.7 && < 0.12 , text == 1.2.* default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/google-translate-0.3/src/Web/Google/Translate.hs new/google-translate-0.4.1/src/Web/Google/Translate.hs --- old/google-translate-0.3/src/Web/Google/Translate.hs 2016-10-18 22:04:59.000000000 +0200 +++ new/google-translate-0.4.1/src/Web/Google/Translate.hs 2017-07-29 03:33:36.000000000 +0200 @@ -41,11 +41,10 @@ , Language (..) ) where ------------------------------------------------------------------------------ -import Control.Monad.Trans.Except import Data.Aeson import Data.Proxy -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T import GHC.Generics import Network.HTTP.Client (Manager) import Servant.API @@ -161,6 +160,7 @@ :> QueryParam "target" Target :> Get '[JSON] LanguageResponse ------------------------------------------------------------------------------ +-- | API type api :: Proxy GoogleTranslateAPI api = Proxy ------------------------------------------------------------------------------

1 0

commit ghc-google-oauth2-jwt for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-google-oauth2-jwt for openSUSE:Factory checked in at 2017-08-31 20:55:33 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-google-oauth2-jwt (Old) and /work/SRC/openSUSE:Factory/.ghc-google-oauth2-jwt.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-google-oauth2-jwt" Thu Aug 31 20:55:33 2017 rev:2 rq:513358 version:0.2.2 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-google-oauth2-jwt/ghc-google-oauth2-jwt.changes 2017-04-14 13:39:36.535382670 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-google-oauth2-jwt.new/ghc-google-oauth2-jwt.changes 2017-08-31 20:55:34.402920373 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:04:14 UTC 2017 - psimons(a)suse.com + +- Update to version 0.2.2. + +------------------------------------------------------------------- Old: ---- google-oauth2-jwt-0.1.3.tar.gz New: ---- google-oauth2-jwt-0.2.2.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-google-oauth2-jwt.spec ++++++ --- /var/tmp/diff_new_pack.snE8o3/_old 2017-08-31 20:55:35.982698409 +0200 +++ /var/tmp/diff_new_pack.snE8o3/_new 2017-08-31 20:55:35.986697847 +0200 @@ -18,7 +18,7 @@ %global pkg_name google-oauth2-jwt Name: ghc-%{pkg_name} -Version: 0.1.3 +Version: 0.2.2 Release: 0 Summary: Get a signed JWT for Google Service Accounts License: BSD-3-Clause @@ -36,7 +36,8 @@ BuildRoot: %{_tmppath}/%{name}-%{version}-build %description -Get a signed JWT for Google Service Accounts. +This library implements the creation of the signed JWT for Google Service +Accounts. %package devel Summary: Haskell %{pkg_name} library development files ++++++ google-oauth2-jwt-0.1.3.tar.gz -> google-oauth2-jwt-0.2.2.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/google-oauth2-jwt-0.1.3/LICENSE new/google-oauth2-jwt-0.2.2/LICENSE --- old/google-oauth2-jwt-0.1.3/LICENSE 2016-09-02 16:34:48.000000000 +0200 +++ new/google-oauth2-jwt-0.2.2/LICENSE 2017-05-30 14:20:50.000000000 +0200 @@ -1,4 +1,4 @@ -google-oauth2-jwt - Copyright Michel Boucey (c) 2016 +google-oauth2-jwt - Copyright Michel Boucey (c) 2016-2017 All rights reserved. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/google-oauth2-jwt-0.1.3/google-oauth2-jwt.cabal new/google-oauth2-jwt-0.2.2/google-oauth2-jwt.cabal --- old/google-oauth2-jwt-0.1.3/google-oauth2-jwt.cabal 2016-12-26 16:34:25.000000000 +0100 +++ new/google-oauth2-jwt-0.2.2/google-oauth2-jwt.cabal 2017-06-09 19:46:44.000000000 +0200 @@ -1,13 +1,14 @@ name: google-oauth2-jwt -version: 0.1.3 +version: 0.2.2 synopsis: Get a signed JWT for Google Service Accounts -description: Please see README.md +description: This library implements the creation of the + signed JWT for Google Service Accounts. homepage: https://github.com/MichelBoucey/google-oauth2-jwt license: BSD3 license-file: LICENSE author: Michel Boucey maintainer: michel.boucey(a)cybervisible.fr -copyright: (c) 2016 - Michel Boucey +copyright: (c) 2016-2017 - Michel Boucey category: Google build-type: Simple extra-source-files: README.md @@ -16,13 +17,13 @@ library hs-source-dirs: src exposed-modules: Network.Google.OAuth2.JWT - build-depends: base >= 4.7 && < 5 - , base64-bytestring >= 1.0.0 && < 1.1 - , bytestring >= 0.10.6 && < 0.11 + build-depends: base >= 4.7 && < 5 + , base64-bytestring >= 1.0.0 && < 1.1 + , bytestring >= 0.10.6 && < 0.11 , HsOpenSSL >= 0.11.1.1 && < 0.12 - , RSA >= 2.1.0.3 && < 2.3 - , text >= 1.2.2 && < 1.3 - , unix-time >= 0.3.6 && < 0.4 + , RSA >= 2.1.0.3 && < 2.4 + , text >= 1.2.2 && < 1.3 + , unix-time >= 0.3.6 && < 0.4 default-language: Haskell2010 GHC-options: -Wall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/google-oauth2-jwt-0.1.3/src/Network/Google/OAuth2/JWT.hs new/google-oauth2-jwt-0.2.2/src/Network/Google/OAuth2/JWT.hs --- old/google-oauth2-jwt-0.1.3/src/Network/Google/OAuth2/JWT.hs 2016-12-17 09:48:30.000000000 +0100 +++ new/google-oauth2-jwt-0.2.2/src/Network/Google/OAuth2/JWT.hs 2017-05-30 14:58:58.000000000 +0200 @@ -8,7 +8,8 @@ module Network.Google.OAuth2.JWT ( - Email + SignedJWT + , Email , Scope , getSignedJWT @@ -19,13 +20,14 @@ ) where import Codec.Crypto.RSA.Pure +import Control.Monad (unless) import qualified Data.ByteString as B import Data.ByteString.Base64.URL (encode) import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Maybe (fromMaybe, fromJust) import Data.Monoid ((<>)) import qualified Data.Text as T -import Data.Text.Encoding +import Data.Text.Encoding (encodeUtf8) import Data.UnixTime (getUnixTime, utSeconds) import Foreign.C.Types import OpenSSL.EVP.PKey (toKeyPair) @@ -33,19 +35,23 @@ readPrivateKey) import OpenSSL.RSA -type Scope = T.Text +data SignedJWT = + SignedJWT !B.ByteString + deriving (Eq, Show) type Email = T.Text +type Scope = T.Text + -- | Get the private key obtained from the --- the Google API Console from a PEM file. +-- Google API Console from a PEM file. fromPEMFile :: FilePath -> IO PrivateKey fromPEMFile f = readFile f >>= fromPEMString -- | Get the private key obtained from the -- Google API Console from a PEM 'String'. -- --- >fromPEMString "-----BEGIN PRIVATE KEY-----\nB9e ... bMdF\n-----END PRIVATE KEY-----\n" +-- >fromPEMString "-----BEGIN PRIVATE KEY-----\nB9e [...] bMdF\n-----END PRIVATE KEY-----\n" -- > fromPEMString :: String -> IO PrivateKey fromPEMString s = @@ -53,10 +59,11 @@ \k -> return PrivateKey { private_pub = - PublicKey { public_size = rsaSize k - , public_n = rsaN k - , public_e = rsaE k - } + PublicKey + { public_size = rsaSize k + , public_n = rsaN k + , public_e = rsaE k + } , private_d = rsaD k , private_p = rsaP k , private_q = rsaQ k @@ -70,41 +77,38 @@ -- -- >grant_type=urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Ajwt-bearer&assertion= -- -getSignedJWT :: Email - -- ^ The email address of the service account. - -> Maybe Email - -- ^ The email address of the user for which the - -- application is requesting delegated access. - -> [Scope] - -- ^ The list of the permissions that the application requests. - -> Maybe Int - -- ^ Expiration time (maximun and default value is an hour, 3600). - -> PrivateKey - -- ^ The private key gotten from the PEM string obtained from the - -- Google API Console. - -> IO (Either String B.ByteString) - -- ^ Either an error message or a signed JWT. +getSignedJWT + :: Email + -- ^ The email address of the service account. + -> Maybe Email + -- ^ The email address of the user for which the + -- application is requesting delegated access. + -> [Scope] + -- ^ The list of the permissions that the application requests. + -> Maybe Int + -- ^ Expiration time (maximun and default value is an hour, 3600). + -> PrivateKey + -- ^ The private key gotten from the PEM string obtained from the + -- Google API Console. + -> IO (Either String SignedJWT) + -- ^ Either an error message or a signed JWT. getSignedJWT iss msub scs mxt pk = do let xt = fromIntegral (fromMaybe 3600 mxt) - if xt >= 1 && xt <= 3600 - then do - cs <- do - let s = maybe T.empty (\e -> "\"sub\":\"" <> e <> "\",") msub - (t',xt') <- getUnixTime >>= - \t -> return (toText (utSeconds t),toText (utSeconds t + CTime xt)) - return $ - toJWT $ - "{\"iss\":\"" <> iss <> "\"," <> s <> "\"scope\":\"" <> - T.intercalate " " scs <> "\",\"aud\":\"https://www.goo\ - \gleapis.com/oauth2/v4/token\",\"exp\":" <> xt' <> ",\"\ - \iat\":" <> t' <> "}" - let i = toJWT "{\"alg\":\"RS256\",\"typ\":\"JWT\"}" <> "." <> cs - return $ - case rsassa_pkcs1_v1_5_sign hashSHA256 pk (fromStrict i) of - Right s -> Right (i <> "." <> encode (toStrict s)) - Left _ -> Left "RSAError" - else fail "Bad expiration time" + unless (xt >= 1 && xt <= 3600) (fail "Bad expiration time") + t <- getUnixTime + let i = header <> "." <> toB64 ("{\"iss\":\"" <> iss <> "\"," + <> maybe T.empty (\e -> "\"sub\":\"" <> e <> "\",") msub + <> "\"scope\":\"" <> T.intercalate " " scs <> "\",\"aud\ + \\":\"https://www.googleapis.com/oauth2/v4/token\",\"ex\ + \p\":" <> toT (utSeconds t + CTime xt) <> ",\"iat\":" + <> toT (utSeconds t) <> "}") + return $ + either + (fail "RSAError") + (\s -> return $ SignedJWT $ i <> "." <> encode (toStrict s)) + (rsassa_pkcs1_v1_5_sign hashSHA256 pk $ fromStrict i) where - toText = T.pack . show - toJWT = encode . encodeUtf8 + toT = T.pack . show + toB64 = encode . encodeUtf8 + header = toB64 "{\"alg\":\"RS256\",\"typ\":\"JWT\"}"

1 0

commit ghc-gogol-youtube-reporting for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-youtube-reporting for openSUSE:Factory checked in at 2017-08-31 20:55:31 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-youtube-reporting (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-youtube-reporting.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-youtube-reporting" Thu Aug 31 20:55:31 2017 rev:2 rq:513357 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-youtube-reporting/ghc-gogol-youtube-reporting.changes 2017-05-10 20:44:46.827419274 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-youtube-reporting.new/ghc-gogol-youtube-reporting.changes 2017-08-31 20:55:32.127240115 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:50 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-youtube-reporting-0.1.1.tar.gz New: ---- gogol-youtube-reporting-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-youtube-reporting.spec ++++++ --- /var/tmp/diff_new_pack.aOSnu1/_old 2017-08-31 20:55:33.823001854 +0200 +++ /var/tmp/diff_new_pack.aOSnu1/_new 2017-08-31 20:55:33.827001292 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-youtube-reporting Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google YouTube Reporting SDK License: MPL-2.0 ++++++ gogol-youtube-reporting-0.1.1.tar.gz -> gogol-youtube-reporting-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/README.md new/gogol-youtube-reporting-0.3.0/README.md --- old/gogol-youtube-reporting-0.1.1/README.md 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/README.md 2017-07-12 16:51:30.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Create.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Create.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Create.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Create.hs 2017-07-12 16:51:30.000000000 +0200 @@ -52,7 +52,7 @@ type JobsCreateResource = "v1" :> "jobs" :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -67,7 +67,7 @@ -- -- /See:/ 'jobsCreate' smart constructor. data JobsCreate = JobsCreate' - { _jcXgafv :: !(Maybe Text) + { _jcXgafv :: !(Maybe Xgafv) , _jcUploadProtocol :: !(Maybe Text) , _jcPp :: !Bool , _jcAccessToken :: !(Maybe Text) @@ -116,7 +116,7 @@ } -- | V1 error format. -jcXgafv :: Lens' JobsCreate (Maybe Text) +jcXgafv :: Lens' JobsCreate (Maybe Xgafv) jcXgafv = lens _jcXgafv (\ s a -> s{_jcXgafv = a}) -- | Upload protocol for media (e.g. \"raw\", \"multipart\"). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Delete.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Delete.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Delete.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Delete.hs 2017-07-12 16:51:30.000000000 +0200 @@ -53,7 +53,7 @@ "v1" :> "jobs" :> Capture "jobId" Text :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -67,7 +67,7 @@ -- -- /See:/ 'jobsDelete' smart constructor. data JobsDelete = JobsDelete' - { _jdXgafv :: !(Maybe Text) + { _jdXgafv :: !(Maybe Xgafv) , _jdJobId :: !Text , _jdUploadProtocol :: !(Maybe Text) , _jdPp :: !Bool @@ -116,7 +116,7 @@ } -- | V1 error format. -jdXgafv :: Lens' JobsDelete (Maybe Text) +jdXgafv :: Lens' JobsDelete (Maybe Xgafv) jdXgafv = lens _jdXgafv (\ s a -> s{_jdXgafv = a}) -- | The ID of the job to delete. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Get.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Get.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Get.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Get.hs 2017-07-12 16:51:30.000000000 +0200 @@ -53,7 +53,7 @@ "v1" :> "jobs" :> Capture "jobId" Text :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -67,7 +67,7 @@ -- -- /See:/ 'jobsGet' smart constructor. data JobsGet = JobsGet' - { _jgXgafv :: !(Maybe Text) + { _jgXgafv :: !(Maybe Xgafv) , _jgJobId :: !Text , _jgUploadProtocol :: !(Maybe Text) , _jgPp :: !Bool @@ -116,7 +116,7 @@ } -- | V1 error format. -jgXgafv :: Lens' JobsGet (Maybe Text) +jgXgafv :: Lens' JobsGet (Maybe Xgafv) jgXgafv = lens _jgXgafv (\ s a -> s{_jgXgafv = a}) -- | The ID of the job to retrieve. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/List.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/List.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/List.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/List.hs 2017-07-12 16:51:30.000000000 +0200 @@ -54,7 +54,7 @@ type JobsListResource = "v1" :> "jobs" :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -72,7 +72,7 @@ -- -- /See:/ 'jobsList' smart constructor. data JobsList = JobsList' - { _jlXgafv :: !(Maybe Text) + { _jlXgafv :: !(Maybe Xgafv) , _jlUploadProtocol :: !(Maybe Text) , _jlPp :: !Bool , _jlAccessToken :: !(Maybe Text) @@ -128,7 +128,7 @@ } -- | V1 error format. -jlXgafv :: Lens' JobsList (Maybe Text) +jlXgafv :: Lens' JobsList (Maybe Xgafv) jlXgafv = lens _jlXgafv (\ s a -> s{_jlXgafv = a}) -- | Upload protocol for media (e.g. \"raw\", \"multipart\"). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/Get.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/Get.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/Get.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/Get.hs 2017-07-12 16:51:30.000000000 +0200 @@ -56,7 +56,7 @@ Capture "jobId" Text :> "reports" :> Capture "reportId" Text :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -70,7 +70,7 @@ -- -- /See:/ 'jobsReportsGet' smart constructor. data JobsReportsGet = JobsReportsGet' - { _jrgXgafv :: !(Maybe Text) + { _jrgXgafv :: !(Maybe Xgafv) , _jrgJobId :: !Text , _jrgUploadProtocol :: !(Maybe Text) , _jrgPp :: !Bool @@ -124,7 +124,7 @@ } -- | V1 error format. -jrgXgafv :: Lens' JobsReportsGet (Maybe Text) +jrgXgafv :: Lens' JobsReportsGet (Maybe Xgafv) jrgXgafv = lens _jrgXgafv (\ s a -> s{_jrgXgafv = a}) -- | The ID of the job. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/List.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/List.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/List.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Jobs/Reports/List.hs 2017-07-12 16:51:30.000000000 +0200 @@ -60,14 +60,14 @@ "jobs" :> Capture "jobId" Text :> "reports" :> - QueryParam "createdAfter" Text :> - QueryParam "$.xgafv" Text :> + QueryParam "createdAfter" DateTime' :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> QueryParam "uploadType" Text :> - QueryParam "startTimeAtOrAfter" Text :> - QueryParam "startTimeBefore" Text :> + QueryParam "startTimeAtOrAfter" DateTime' :> + QueryParam "startTimeBefore" DateTime' :> QueryParam "onBehalfOfContentOwner" Text :> QueryParam "bearer_token" Text :> QueryParam "pageToken" Text :> @@ -81,15 +81,15 @@ -- -- /See:/ 'jobsReportsList' smart constructor. data JobsReportsList = JobsReportsList' - { _jrlCreatedAfter :: !(Maybe Text) - , _jrlXgafv :: !(Maybe Text) + { _jrlCreatedAfter :: !(Maybe DateTime') + , _jrlXgafv :: !(Maybe Xgafv) , _jrlJobId :: !Text , _jrlUploadProtocol :: !(Maybe Text) , _jrlPp :: !Bool , _jrlAccessToken :: !(Maybe Text) , _jrlUploadType :: !(Maybe Text) - , _jrlStartTimeAtOrAfter :: !(Maybe Text) - , _jrlStartTimeBefore :: !(Maybe Text) + , _jrlStartTimeAtOrAfter :: !(Maybe DateTime') + , _jrlStartTimeBefore :: !(Maybe DateTime') , _jrlOnBehalfOfContentOwner :: !(Maybe Text) , _jrlBearerToken :: !(Maybe Text) , _jrlPageToken :: !(Maybe Text) @@ -151,13 +151,14 @@ -- | If set, only reports created after the specified date\/time are -- returned. -jrlCreatedAfter :: Lens' JobsReportsList (Maybe Text) +jrlCreatedAfter :: Lens' JobsReportsList (Maybe UTCTime) jrlCreatedAfter = lens _jrlCreatedAfter (\ s a -> s{_jrlCreatedAfter = a}) + . mapping _DateTime -- | V1 error format. -jrlXgafv :: Lens' JobsReportsList (Maybe Text) +jrlXgafv :: Lens' JobsReportsList (Maybe Xgafv) jrlXgafv = lens _jrlXgafv (\ s a -> s{_jrlXgafv = a}) -- | The ID of the job. @@ -188,17 +189,19 @@ -- | If set, only reports whose start time is greater than or equal the -- specified date\/time are returned. -jrlStartTimeAtOrAfter :: Lens' JobsReportsList (Maybe Text) +jrlStartTimeAtOrAfter :: Lens' JobsReportsList (Maybe UTCTime) jrlStartTimeAtOrAfter = lens _jrlStartTimeAtOrAfter (\ s a -> s{_jrlStartTimeAtOrAfter = a}) + . mapping _DateTime -- | If set, only reports whose start time is smaller than the specified -- date\/time are returned. -jrlStartTimeBefore :: Lens' JobsReportsList (Maybe Text) +jrlStartTimeBefore :: Lens' JobsReportsList (Maybe UTCTime) jrlStartTimeBefore = lens _jrlStartTimeBefore (\ s a -> s{_jrlStartTimeBefore = a}) + . mapping _DateTime -- | The content owner\'s external ID on which behalf the user is acting on. -- If not set, the user is acting for himself (his own channel). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Media/Download.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Media/Download.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/Media/Download.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/Media/Download.hs 2017-07-12 16:51:30.000000000 +0200 @@ -53,7 +53,7 @@ "v1" :> "media" :> Capture "resourceName" Text :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -65,7 +65,7 @@ "v1" :> "media" :> Capture "resourceName" Text :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -80,7 +80,7 @@ -- -- /See:/ 'mediaDownload' smart constructor. data MediaDownload' = MediaDownload'' - { _mdXgafv :: !(Maybe Text) + { _mdXgafv :: !(Maybe Xgafv) , _mdUploadProtocol :: !(Maybe Text) , _mdResourceName :: !Text , _mdPp :: !Bool @@ -125,7 +125,7 @@ } -- | V1 error format. -mdXgafv :: Lens' MediaDownload' (Maybe Text) +mdXgafv :: Lens' MediaDownload' (Maybe Xgafv) mdXgafv = lens _mdXgafv (\ s a -> s{_mdXgafv = a}) -- | Upload protocol for media (e.g. \"raw\", \"multipart\"). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/ReportTypes/List.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/ReportTypes/List.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/Resource/YouTubeReporting/ReportTypes/List.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/Resource/YouTubeReporting/ReportTypes/List.hs 2017-07-12 16:51:30.000000000 +0200 @@ -54,7 +54,7 @@ type ReportTypesListResource = "v1" :> "reportTypes" :> - QueryParam "$.xgafv" Text :> + QueryParam "$.xgafv" Xgafv :> QueryParam "upload_protocol" Text :> QueryParam "pp" Bool :> QueryParam "access_token" Text :> @@ -72,7 +72,7 @@ -- -- /See:/ 'reportTypesList' smart constructor. data ReportTypesList = ReportTypesList' - { _rtlXgafv :: !(Maybe Text) + { _rtlXgafv :: !(Maybe Xgafv) , _rtlUploadProtocol :: !(Maybe Text) , _rtlPp :: !Bool , _rtlAccessToken :: !(Maybe Text) @@ -128,7 +128,7 @@ } -- | V1 error format. -rtlXgafv :: Lens' ReportTypesList (Maybe Text) +rtlXgafv :: Lens' ReportTypesList (Maybe Xgafv) rtlXgafv = lens _rtlXgafv (\ s a -> s{_rtlXgafv = a}) -- | Upload protocol for media (e.g. \"raw\", \"multipart\"). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting/Types/Product.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting/Types/Product.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting/Types/Product.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting/Types/Product.hs 2017-07-12 16:51:30.000000000 +0200 @@ -102,12 +102,12 @@ -- /See:/ 'report' smart constructor. data Report = Report' { _rJobId :: !(Maybe Text) - , _rStartTime :: !(Maybe Text) + , _rStartTime :: !(Maybe DateTime') , _rDownloadURL :: !(Maybe Text) - , _rEndTime :: !(Maybe Text) + , _rEndTime :: !(Maybe DateTime') , _rId :: !(Maybe Text) - , _rCreateTime :: !(Maybe Text) - , _rJobExpireTime :: !(Maybe Text) + , _rCreateTime :: !(Maybe DateTime') + , _rJobExpireTime :: !(Maybe DateTime') } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'Report' with the minimum fields required to make a request. @@ -146,9 +146,10 @@ -- | The start of the time period that the report instance covers. The value -- is inclusive. -rStartTime :: Lens' Report (Maybe Text) +rStartTime :: Lens' Report (Maybe UTCTime) rStartTime - = lens _rStartTime (\ s a -> s{_rStartTime = a}) + = lens _rStartTime (\ s a -> s{_rStartTime = a}) . + mapping _DateTime -- | The URL from which the report can be downloaded (max. 1000 characters). rDownloadURL :: Lens' Report (Maybe Text) @@ -157,23 +158,27 @@ -- | The end of the time period that the report instance covers. The value is -- exclusive. -rEndTime :: Lens' Report (Maybe Text) -rEndTime = lens _rEndTime (\ s a -> s{_rEndTime = a}) +rEndTime :: Lens' Report (Maybe UTCTime) +rEndTime + = lens _rEndTime (\ s a -> s{_rEndTime = a}) . + mapping _DateTime -- | The server-generated ID of the report. rId :: Lens' Report (Maybe Text) rId = lens _rId (\ s a -> s{_rId = a}) -- | The date\/time when this report was created. -rCreateTime :: Lens' Report (Maybe Text) +rCreateTime :: Lens' Report (Maybe UTCTime) rCreateTime - = lens _rCreateTime (\ s a -> s{_rCreateTime = a}) + = lens _rCreateTime (\ s a -> s{_rCreateTime = a}) . + mapping _DateTime -- | The date\/time when the job this report belongs to will expire\/expired. -rJobExpireTime :: Lens' Report (Maybe Text) +rJobExpireTime :: Lens' Report (Maybe UTCTime) rJobExpireTime = lens _rJobExpireTime (\ s a -> s{_rJobExpireTime = a}) + . mapping _DateTime instance FromJSON Report where parseJSON @@ -295,8 +300,8 @@ , _jId :: !(Maybe Text) , _jSystemManaged :: !(Maybe Bool) , _jReportTypeId :: !(Maybe Text) - , _jExpireTime :: !(Maybe Text) - , _jCreateTime :: !(Maybe Text) + , _jExpireTime :: !(Maybe DateTime') + , _jCreateTime :: !(Maybe DateTime') } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'Job' with the minimum fields required to make a request. @@ -350,14 +355,16 @@ -- | The date\/time when this job will expire\/expired. After a job expired, -- no new reports are generated. -jExpireTime :: Lens' Job (Maybe Text) +jExpireTime :: Lens' Job (Maybe UTCTime) jExpireTime - = lens _jExpireTime (\ s a -> s{_jExpireTime = a}) + = lens _jExpireTime (\ s a -> s{_jExpireTime = a}) . + mapping _DateTime -- | The creation date\/time of the job. -jCreateTime :: Lens' Job (Maybe Text) +jCreateTime :: Lens' Job (Maybe UTCTime) jCreateTime - = lens _jCreateTime (\ s a -> s{_jCreateTime = a}) + = lens _jCreateTime (\ s a -> s{_jCreateTime = a}) . + mapping _DateTime instance FromJSON Job where parseJSON @@ -438,7 +445,7 @@ data ReportType = ReportType' { _rtName :: !(Maybe Text) , _rtId :: !(Maybe Text) - , _rtDeprecateTime :: !(Maybe Text) + , _rtDeprecateTime :: !(Maybe DateTime') , _rtSystemManaged :: !(Maybe Bool) } deriving (Eq,Show,Data,Typeable,Generic) @@ -472,10 +479,11 @@ rtId = lens _rtId (\ s a -> s{_rtId = a}) -- | The date\/time when this report type was\/will be deprecated. -rtDeprecateTime :: Lens' ReportType (Maybe Text) +rtDeprecateTime :: Lens' ReportType (Maybe UTCTime) rtDeprecateTime = lens _rtDeprecateTime (\ s a -> s{_rtDeprecateTime = a}) + . mapping _DateTime -- | True if this a system-managed report type; otherwise false. Reporting -- jobs for system-managed report types are created automatically and can diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting/Types/Sum.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting/Types/Sum.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting/Types/Sum.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting/Types/Sum.hs 2017-07-12 16:51:30.000000000 +0200 @@ -17,3 +17,32 @@ module Network.Google.YouTubeReporting.Types.Sum where import Network.Google.Prelude + +-- | V1 error format. +data Xgafv + = X1 + -- ^ @1@ + -- v1 error format + | X2 + -- ^ @2@ + -- v2 error format + deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) + +instance Hashable Xgafv + +instance FromHttpApiData Xgafv where + parseQueryParam = \case + "1" -> Right X1 + "2" -> Right X2 + x -> Left ("Unable to parse Xgafv from: " <> x) + +instance ToHttpApiData Xgafv where + toQueryParam = \case + X1 -> "1" + X2 -> "2" + +instance FromJSON Xgafv where + parseJSON = parseJSONText "Xgafv" + +instance ToJSON Xgafv where + toJSON = toJSONText diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting/Types.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting/Types.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting/Types.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting/Types.hs 2017-07-12 16:51:30.000000000 +0200 @@ -65,6 +65,9 @@ , jExpireTime , jCreateTime + -- * Xgafv + , Xgafv (..) + -- * ListJobsResponse , ListJobsResponse , listJobsResponse diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting.hs new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting.hs --- old/gogol-youtube-reporting-0.1.1/gen/Network/Google/YouTubeReporting.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gen/Network/Google/YouTubeReporting.hs 2017-07-12 16:51:30.000000000 +0200 @@ -99,6 +99,9 @@ , jExpireTime , jCreateTime + -- ** Xgafv + , Xgafv (..) + -- ** ListJobsResponse , ListJobsResponse , listJobsResponse diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-reporting-0.1.1/gogol-youtube-reporting.cabal new/gogol-youtube-reporting-0.3.0/gogol-youtube-reporting.cabal --- old/gogol-youtube-reporting-0.1.1/gogol-youtube-reporting.cabal 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-reporting-0.3.0/gogol-youtube-reporting.cabal 2017-07-12 16:51:30.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-youtube-reporting -version: 0.1.1 +version: 0.3.0 synopsis: Google YouTube Reporting SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -50,5 +50,5 @@ , Network.Google.YouTubeReporting.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-youtube-analytics for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-youtube-analytics for openSUSE:Factory checked in at 2017-08-31 20:55:29 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-youtube-analytics (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-youtube-analytics.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-youtube-analytics" Thu Aug 31 20:55:29 2017 rev:2 rq:513356 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-youtube-analytics/ghc-gogol-youtube-analytics.changes 2017-05-10 20:44:37.512733591 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-youtube-analytics.new/ghc-gogol-youtube-analytics.changes 2017-08-31 20:55:29.975542435 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:08 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-youtube-analytics-0.1.1.tar.gz New: ---- gogol-youtube-analytics-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-youtube-analytics.spec ++++++ --- /var/tmp/diff_new_pack.K5jtjO/_old 2017-08-31 20:55:31.251363178 +0200 +++ /var/tmp/diff_new_pack.K5jtjO/_new 2017-08-31 20:55:31.275359807 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-youtube-analytics Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google YouTube Analytics SDK License: MPL-2.0 ++++++ gogol-youtube-analytics-0.1.1.tar.gz -> gogol-youtube-analytics-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-analytics-0.1.1/README.md new/gogol-youtube-analytics-0.3.0/README.md --- old/gogol-youtube-analytics-0.1.1/README.md 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-analytics-0.3.0/README.md 2017-07-12 16:51:30.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-analytics-0.1.1/gen/Network/Google/Resource/YouTubeAnalytics/BatchReportDefinitions/List.hs new/gogol-youtube-analytics-0.3.0/gen/Network/Google/Resource/YouTubeAnalytics/BatchReportDefinitions/List.hs --- old/gogol-youtube-analytics-0.1.1/gen/Network/Google/Resource/YouTubeAnalytics/BatchReportDefinitions/List.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-analytics-0.3.0/gen/Network/Google/Resource/YouTubeAnalytics/BatchReportDefinitions/List.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,94 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - --- | --- Module : Network.Google.Resource.YouTubeAnalytics.BatchReportDefinitions.List --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay <brendan.g.hay(a)gmail.com> --- Stability : auto-generated --- Portability : non-portable (GHC extensions) --- --- Retrieves a list of available batch report definitions. --- --- /See:/ <http://developers.google.com/youtube/analytics/ YouTube Analytics API Reference> for @youtubeAnalytics.batchReportDefinitions.list@. -module Network.Google.Resource.YouTubeAnalytics.BatchReportDefinitions.List - ( - -- * REST Resource - BatchReportDefinitionsListResource - - -- * Creating a Request - , batchReportDefinitionsList - , BatchReportDefinitionsList - - -- * Request Lenses - , brdlOnBehalfOfContentOwner - ) where - -import Network.Google.Prelude -import Network.Google.YouTubeAnalytics.Types - --- | A resource alias for @youtubeAnalytics.batchReportDefinitions.list@ method which the --- 'BatchReportDefinitionsList' request conforms to. -type BatchReportDefinitionsListResource = - "youtube" :> - "analytics" :> - "v1" :> - "batchReportDefinitions" :> - QueryParam "onBehalfOfContentOwner" Text :> - QueryParam "alt" AltJSON :> - Get '[JSON] BatchReportDefinitionList - --- | Retrieves a list of available batch report definitions. --- --- /See:/ 'batchReportDefinitionsList' smart constructor. -newtype BatchReportDefinitionsList = BatchReportDefinitionsList' - { _brdlOnBehalfOfContentOwner :: Text - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReportDefinitionsList' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'brdlOnBehalfOfContentOwner' -batchReportDefinitionsList - :: Text -- ^ 'brdlOnBehalfOfContentOwner' - -> BatchReportDefinitionsList -batchReportDefinitionsList pBrdlOnBehalfOfContentOwner_ = - BatchReportDefinitionsList' - { _brdlOnBehalfOfContentOwner = pBrdlOnBehalfOfContentOwner_ - } - --- | The onBehalfOfContentOwner parameter identifies the content owner that --- the user is acting on behalf of. -brdlOnBehalfOfContentOwner :: Lens' BatchReportDefinitionsList Text -brdlOnBehalfOfContentOwner - = lens _brdlOnBehalfOfContentOwner - (\ s a -> s{_brdlOnBehalfOfContentOwner = a}) - -instance GoogleRequest BatchReportDefinitionsList - where - type Rs BatchReportDefinitionsList = - BatchReportDefinitionList - type Scopes BatchReportDefinitionsList = - '["https://www.googleapis.com/auth/yt-analytics-monetary.readonly", - "https://www.googleapis.com/auth/yt-analytics.readonly"] - requestClient BatchReportDefinitionsList'{..} - = go (Just _brdlOnBehalfOfContentOwner) - (Just AltJSON) - youTubeAnalyticsService - where go - = buildClient - (Proxy :: Proxy BatchReportDefinitionsListResource) - mempty diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-analytics-0.1.1/gen/Network/Google/Resource/YouTubeAnalytics/BatchReports/List.hs new/gogol-youtube-analytics-0.3.0/gen/Network/Google/Resource/YouTubeAnalytics/BatchReports/List.hs --- old/gogol-youtube-analytics-0.1.1/gen/Network/Google/Resource/YouTubeAnalytics/BatchReports/List.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-analytics-0.3.0/gen/Network/Google/Resource/YouTubeAnalytics/BatchReports/List.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,107 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - --- | --- Module : Network.Google.Resource.YouTubeAnalytics.BatchReports.List --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay <brendan.g.hay(a)gmail.com> --- Stability : auto-generated --- Portability : non-portable (GHC extensions) --- --- Retrieves a list of processed batch reports. --- --- /See:/ <http://developers.google.com/youtube/analytics/ YouTube Analytics API Reference> for @youtubeAnalytics.batchReports.list@. -module Network.Google.Resource.YouTubeAnalytics.BatchReports.List - ( - -- * REST Resource - BatchReportsListResource - - -- * Creating a Request - , batchReportsList - , BatchReportsList - - -- * Request Lenses - , brlBatchReportDefinitionId - , brlOnBehalfOfContentOwner - ) where - -import Network.Google.Prelude -import Network.Google.YouTubeAnalytics.Types - --- | A resource alias for @youtubeAnalytics.batchReports.list@ method which the --- 'BatchReportsList' request conforms to. -type BatchReportsListResource = - "youtube" :> - "analytics" :> - "v1" :> - "batchReports" :> - QueryParam "batchReportDefinitionId" Text :> - QueryParam "onBehalfOfContentOwner" Text :> - QueryParam "alt" AltJSON :> - Get '[JSON] BatchReportList - --- | Retrieves a list of processed batch reports. --- --- /See:/ 'batchReportsList' smart constructor. -data BatchReportsList = BatchReportsList' - { _brlBatchReportDefinitionId :: !Text - , _brlOnBehalfOfContentOwner :: !Text - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReportsList' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'brlBatchReportDefinitionId' --- --- * 'brlOnBehalfOfContentOwner' -batchReportsList - :: Text -- ^ 'brlBatchReportDefinitionId' - -> Text -- ^ 'brlOnBehalfOfContentOwner' - -> BatchReportsList -batchReportsList pBrlBatchReportDefinitionId_ pBrlOnBehalfOfContentOwner_ = - BatchReportsList' - { _brlBatchReportDefinitionId = pBrlBatchReportDefinitionId_ - , _brlOnBehalfOfContentOwner = pBrlOnBehalfOfContentOwner_ - } - --- | The batchReportDefinitionId parameter specifies the ID of the batch --- reportort definition for which you are retrieving reports. -brlBatchReportDefinitionId :: Lens' BatchReportsList Text -brlBatchReportDefinitionId - = lens _brlBatchReportDefinitionId - (\ s a -> s{_brlBatchReportDefinitionId = a}) - --- | The onBehalfOfContentOwner parameter identifies the content owner that --- the user is acting on behalf of. -brlOnBehalfOfContentOwner :: Lens' BatchReportsList Text -brlOnBehalfOfContentOwner - = lens _brlOnBehalfOfContentOwner - (\ s a -> s{_brlOnBehalfOfContentOwner = a}) - -instance GoogleRequest BatchReportsList where - type Rs BatchReportsList = BatchReportList - type Scopes BatchReportsList = - '["https://www.googleapis.com/auth/yt-analytics-monetary.readonly", - "https://www.googleapis.com/auth/yt-analytics.readonly"] - requestClient BatchReportsList'{..} - = go (Just _brlBatchReportDefinitionId) - (Just _brlOnBehalfOfContentOwner) - (Just AltJSON) - youTubeAnalyticsService - where go - = buildClient - (Proxy :: Proxy BatchReportsListResource) - mempty diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-analytics-0.1.1/gen/Network/Google/YouTubeAnalytics/Types/Product.hs new/gogol-youtube-analytics-0.3.0/gen/Network/Google/YouTubeAnalytics/Types/Product.hs --- old/gogol-youtube-analytics-0.1.1/gen/Network/Google/YouTubeAnalytics/Types/Product.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-analytics-0.3.0/gen/Network/Google/YouTubeAnalytics/Types/Product.hs 2017-07-12 16:51:30.000000000 +0200 @@ -317,180 +317,6 @@ [Just ("kind" .= _rtKind), ("rows" .=) <$> _rtRows, ("columnHeaders" .=) <$> _rtColumnHeaders]) --- | Contains single batchReportDefinition resource. --- --- /See:/ 'batchReportDefinition' smart constructor. -data BatchReportDefinition = BatchReportDefinition' - { _brdStatus :: !(Maybe Text) - , _brdKind :: !Text - , _brdName :: !(Maybe Text) - , _brdId :: !(Maybe Text) - , _brdType :: !(Maybe Text) - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReportDefinition' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'brdStatus' --- --- * 'brdKind' --- --- * 'brdName' --- --- * 'brdId' --- --- * 'brdType' -batchReportDefinition - :: BatchReportDefinition -batchReportDefinition = - BatchReportDefinition' - { _brdStatus = Nothing - , _brdKind = "youtubeAnalytics#batchReportDefinition" - , _brdName = Nothing - , _brdId = Nothing - , _brdType = Nothing - } - --- | Status of the report definition. -brdStatus :: Lens' BatchReportDefinition (Maybe Text) -brdStatus - = lens _brdStatus (\ s a -> s{_brdStatus = a}) - --- | This value specifies the type of data of this item. For batch report --- definition the kind property value is --- youtubeAnalytics#batchReportDefinition. -brdKind :: Lens' BatchReportDefinition Text -brdKind = lens _brdKind (\ s a -> s{_brdKind = a}) - --- | Name of the report definition. -brdName :: Lens' BatchReportDefinition (Maybe Text) -brdName = lens _brdName (\ s a -> s{_brdName = a}) - --- | The ID that YouTube assigns and uses to uniquely identify the report --- definition. -brdId :: Lens' BatchReportDefinition (Maybe Text) -brdId = lens _brdId (\ s a -> s{_brdId = a}) - --- | Type of the report definition. -brdType :: Lens' BatchReportDefinition (Maybe Text) -brdType = lens _brdType (\ s a -> s{_brdType = a}) - -instance FromJSON BatchReportDefinition where - parseJSON - = withObject "BatchReportDefinition" - (\ o -> - BatchReportDefinition' <$> - (o .:? "status") <*> - (o .:? "kind" .!= - "youtubeAnalytics#batchReportDefinition") - <*> (o .:? "name") - <*> (o .:? "id") - <*> (o .:? "type")) - -instance ToJSON BatchReportDefinition where - toJSON BatchReportDefinition'{..} - = object - (catMaybes - [("status" .=) <$> _brdStatus, - Just ("kind" .= _brdKind), ("name" .=) <$> _brdName, - ("id" .=) <$> _brdId, ("type" .=) <$> _brdType]) - --- | Contains single batchReport resource. --- --- /See:/ 'batchReport' smart constructor. -data BatchReport = BatchReport' - { _brTimeUpdated :: !(Maybe DateTime') - , _brKind :: !Text - , _brReportId :: !(Maybe Text) - , _brTimeSpan :: !(Maybe BatchReportTimeSpan) - , _brOutputs :: !(Maybe [BatchReportOutputsItem]) - , _brId :: !(Maybe Text) - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReport' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'brTimeUpdated' --- --- * 'brKind' --- --- * 'brReportId' --- --- * 'brTimeSpan' --- --- * 'brOutputs' --- --- * 'brId' -batchReport - :: BatchReport -batchReport = - BatchReport' - { _brTimeUpdated = Nothing - , _brKind = "youtubeAnalytics#batchReport" - , _brReportId = Nothing - , _brTimeSpan = Nothing - , _brOutputs = Nothing - , _brId = Nothing - } - --- | The time when the report was updated. -brTimeUpdated :: Lens' BatchReport (Maybe UTCTime) -brTimeUpdated - = lens _brTimeUpdated - (\ s a -> s{_brTimeUpdated = a}) - . mapping _DateTime - --- | This value specifies the type of data of this item. For batch report the --- kind property value is youtubeAnalytics#batchReport. -brKind :: Lens' BatchReport Text -brKind = lens _brKind (\ s a -> s{_brKind = a}) - --- | The ID of the the report definition. -brReportId :: Lens' BatchReport (Maybe Text) -brReportId - = lens _brReportId (\ s a -> s{_brReportId = a}) - --- | Period included in the report. For reports containing all entities --- endTime is not set. Both startTime and endTime are inclusive. -brTimeSpan :: Lens' BatchReport (Maybe BatchReportTimeSpan) -brTimeSpan - = lens _brTimeSpan (\ s a -> s{_brTimeSpan = a}) - --- | Report outputs. -brOutputs :: Lens' BatchReport [BatchReportOutputsItem] -brOutputs - = lens _brOutputs (\ s a -> s{_brOutputs = a}) . - _Default - . _Coerce - --- | The ID that YouTube assigns and uses to uniquely identify the report. -brId :: Lens' BatchReport (Maybe Text) -brId = lens _brId (\ s a -> s{_brId = a}) - -instance FromJSON BatchReport where - parseJSON - = withObject "BatchReport" - (\ o -> - BatchReport' <$> - (o .:? "timeUpdated") <*> - (o .:? "kind" .!= "youtubeAnalytics#batchReport") - <*> (o .:? "reportId") - <*> (o .:? "timeSpan") - <*> (o .:? "outputs" .!= mempty) - <*> (o .:? "id")) - -instance ToJSON BatchReport where - toJSON BatchReport'{..} - = object - (catMaybes - [("timeUpdated" .=) <$> _brTimeUpdated, - Just ("kind" .= _brKind), - ("reportId" .=) <$> _brReportId, - ("timeSpan" .=) <$> _brTimeSpan, - ("outputs" .=) <$> _brOutputs, ("id" .=) <$> _brId]) - -- -- /See:/ 'groupSnippet' smart constructor. data GroupSnippet = GroupSnippet' @@ -606,222 +432,6 @@ ("resource" .=) <$> _giResource, ("groupId" .=) <$> _giGroupId, ("id" .=) <$> _giId]) --- | A paginated list of batchReportDefinition resources returned in response --- to a youtubeAnalytics.batchReportDefinitions.list request. --- --- /See:/ 'batchReportDefinitionList' smart constructor. -data BatchReportDefinitionList = BatchReportDefinitionList' - { _brdlKind :: !Text - , _brdlItems :: !(Maybe [BatchReportDefinition]) - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReportDefinitionList' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'brdlKind' --- --- * 'brdlItems' -batchReportDefinitionList - :: BatchReportDefinitionList -batchReportDefinitionList = - BatchReportDefinitionList' - { _brdlKind = "youtubeAnalytics#batchReportDefinitionList" - , _brdlItems = Nothing - } - --- | This value specifies the type of data included in the API response. For --- the list method, the kind property value is --- youtubeAnalytics#batchReportDefinitionList. -brdlKind :: Lens' BatchReportDefinitionList Text -brdlKind = lens _brdlKind (\ s a -> s{_brdlKind = a}) - --- | A list of batchReportDefinition resources that match the request --- criteria. -brdlItems :: Lens' BatchReportDefinitionList [BatchReportDefinition] -brdlItems - = lens _brdlItems (\ s a -> s{_brdlItems = a}) . - _Default - . _Coerce - -instance FromJSON BatchReportDefinitionList where - parseJSON - = withObject "BatchReportDefinitionList" - (\ o -> - BatchReportDefinitionList' <$> - (o .:? "kind" .!= - "youtubeAnalytics#batchReportDefinitionList") - <*> (o .:? "items" .!= mempty)) - -instance ToJSON BatchReportDefinitionList where - toJSON BatchReportDefinitionList'{..} - = object - (catMaybes - [Just ("kind" .= _brdlKind), - ("items" .=) <$> _brdlItems]) - --- | A paginated list of batchReport resources returned in response to a --- youtubeAnalytics.batchReport.list request. --- --- /See:/ 'batchReportList' smart constructor. -data BatchReportList = BatchReportList' - { _brlKind :: !Text - , _brlItems :: !(Maybe [BatchReport]) - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReportList' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'brlKind' --- --- * 'brlItems' -batchReportList - :: BatchReportList -batchReportList = - BatchReportList' - { _brlKind = "youtubeAnalytics#batchReportList" - , _brlItems = Nothing - } - --- | This value specifies the type of data included in the API response. For --- the list method, the kind property value is --- youtubeAnalytics#batchReportList. -brlKind :: Lens' BatchReportList Text -brlKind = lens _brlKind (\ s a -> s{_brlKind = a}) - --- | A list of batchReport resources that match the request criteria. -brlItems :: Lens' BatchReportList [BatchReport] -brlItems - = lens _brlItems (\ s a -> s{_brlItems = a}) . - _Default - . _Coerce - -instance FromJSON BatchReportList where - parseJSON - = withObject "BatchReportList" - (\ o -> - BatchReportList' <$> - (o .:? "kind" .!= "youtubeAnalytics#batchReportList") - <*> (o .:? "items" .!= mempty)) - -instance ToJSON BatchReportList where - toJSON BatchReportList'{..} - = object - (catMaybes - [Just ("kind" .= _brlKind), - ("items" .=) <$> _brlItems]) - --- --- /See:/ 'batchReportOutputsItem' smart constructor. -data BatchReportOutputsItem = BatchReportOutputsItem' - { _broiFormat :: !(Maybe Text) - , _broiDownloadURL :: !(Maybe Text) - , _broiType :: !Text - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReportOutputsItem' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'broiFormat' --- --- * 'broiDownloadURL' --- --- * 'broiType' -batchReportOutputsItem - :: BatchReportOutputsItem -batchReportOutputsItem = - BatchReportOutputsItem' - { _broiFormat = Nothing - , _broiDownloadURL = Nothing - , _broiType = "cloudStorageOutput" - } - --- | Format of the output. -broiFormat :: Lens' BatchReportOutputsItem (Maybe Text) -broiFormat - = lens _broiFormat (\ s a -> s{_broiFormat = a}) - --- | Cloud storage URL to download this report. This URL is valid for 30 --- minutes. -broiDownloadURL :: Lens' BatchReportOutputsItem (Maybe Text) -broiDownloadURL - = lens _broiDownloadURL - (\ s a -> s{_broiDownloadURL = a}) - --- | Type of the output. -broiType :: Lens' BatchReportOutputsItem Text -broiType = lens _broiType (\ s a -> s{_broiType = a}) - -instance FromJSON BatchReportOutputsItem where - parseJSON - = withObject "BatchReportOutputsItem" - (\ o -> - BatchReportOutputsItem' <$> - (o .:? "format") <*> (o .:? "downloadUrl") <*> - (o .:? "type" .!= "cloudStorageOutput")) - -instance ToJSON BatchReportOutputsItem where - toJSON BatchReportOutputsItem'{..} - = object - (catMaybes - [("format" .=) <$> _broiFormat, - ("downloadUrl" .=) <$> _broiDownloadURL, - Just ("type" .= _broiType)]) - --- | Period included in the report. For reports containing all entities --- endTime is not set. Both startTime and endTime are inclusive. --- --- /See:/ 'batchReportTimeSpan' smart constructor. -data BatchReportTimeSpan = BatchReportTimeSpan' - { _brtsStartTime :: !(Maybe DateTime') - , _brtsEndTime :: !(Maybe DateTime') - } deriving (Eq,Show,Data,Typeable,Generic) - --- | Creates a value of 'BatchReportTimeSpan' with the minimum fields required to make a request. --- --- Use one of the following lenses to modify other fields as desired: --- --- * 'brtsStartTime' --- --- * 'brtsEndTime' -batchReportTimeSpan - :: BatchReportTimeSpan -batchReportTimeSpan = - BatchReportTimeSpan' - { _brtsStartTime = Nothing - , _brtsEndTime = Nothing - } - --- | Start of the period included in the report. Inclusive. -brtsStartTime :: Lens' BatchReportTimeSpan (Maybe UTCTime) -brtsStartTime - = lens _brtsStartTime - (\ s a -> s{_brtsStartTime = a}) - . mapping _DateTime - --- | End of the period included in the report. Inclusive. For reports --- containing all entities endTime is not set. -brtsEndTime :: Lens' BatchReportTimeSpan (Maybe UTCTime) -brtsEndTime - = lens _brtsEndTime (\ s a -> s{_brtsEndTime = a}) . - mapping _DateTime - -instance FromJSON BatchReportTimeSpan where - parseJSON - = withObject "BatchReportTimeSpan" - (\ o -> - BatchReportTimeSpan' <$> - (o .:? "startTime") <*> (o .:? "endTime")) - -instance ToJSON BatchReportTimeSpan where - toJSON BatchReportTimeSpan'{..} - = object - (catMaybes - [("startTime" .=) <$> _brtsStartTime, - ("endTime" .=) <$> _brtsEndTime]) - -- | A paginated list of grouList resources returned in response to a -- youtubeAnalytics.groupApi.list request. -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-analytics-0.1.1/gen/Network/Google/YouTubeAnalytics/Types.hs new/gogol-youtube-analytics-0.3.0/gen/Network/Google/YouTubeAnalytics/Types.hs --- old/gogol-youtube-analytics-0.1.1/gen/Network/Google/YouTubeAnalytics/Types.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-analytics-0.3.0/gen/Network/Google/YouTubeAnalytics/Types.hs 2017-07-12 16:51:30.000000000 +0200 @@ -61,25 +61,6 @@ , rtRows , rtColumnHeaders - -- * BatchReportDefinition - , BatchReportDefinition - , batchReportDefinition - , brdStatus - , brdKind - , brdName - , brdId - , brdType - - -- * BatchReport - , BatchReport - , batchReport - , brTimeUpdated - , brKind - , brReportId - , brTimeSpan - , brOutputs - , brId - -- * GroupSnippet , GroupSnippet , groupSnippet @@ -95,31 +76,6 @@ , giGroupId , giId - -- * BatchReportDefinitionList - , BatchReportDefinitionList - , batchReportDefinitionList - , brdlKind - , brdlItems - - -- * BatchReportList - , BatchReportList - , batchReportList - , brlKind - , brlItems - - -- * BatchReportOutputsItem - , BatchReportOutputsItem - , batchReportOutputsItem - , broiFormat - , broiDownloadURL - , broiType - - -- * BatchReportTimeSpan - , BatchReportTimeSpan - , batchReportTimeSpan - , brtsStartTime - , brtsEndTime - -- * GroupItemListResponse , GroupItemListResponse , groupItemListResponse diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-analytics-0.1.1/gen/Network/Google/YouTubeAnalytics.hs new/gogol-youtube-analytics-0.3.0/gen/Network/Google/YouTubeAnalytics.hs --- old/gogol-youtube-analytics-0.1.1/gen/Network/Google/YouTubeAnalytics.hs 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-analytics-0.3.0/gen/Network/Google/YouTubeAnalytics.hs 2017-07-12 16:51:30.000000000 +0200 @@ -33,12 +33,6 @@ -- * Resources - -- ** youtubeAnalytics.batchReportDefinitions.list - , module Network.Google.Resource.YouTubeAnalytics.BatchReportDefinitions.List - - -- ** youtubeAnalytics.batchReports.list - , module Network.Google.Resource.YouTubeAnalytics.BatchReports.List - -- ** youtubeAnalytics.groupItems.delete , module Network.Google.Resource.YouTubeAnalytics.GroupItems.Delete @@ -100,25 +94,6 @@ , rtRows , rtColumnHeaders - -- ** BatchReportDefinition - , BatchReportDefinition - , batchReportDefinition - , brdStatus - , brdKind - , brdName - , brdId - , brdType - - -- ** BatchReport - , BatchReport - , batchReport - , brTimeUpdated - , brKind - , brReportId - , brTimeSpan - , brOutputs - , brId - -- ** GroupSnippet , GroupSnippet , groupSnippet @@ -134,31 +109,6 @@ , giGroupId , giId - -- ** BatchReportDefinitionList - , BatchReportDefinitionList - , batchReportDefinitionList - , brdlKind - , brdlItems - - -- ** BatchReportList - , BatchReportList - , batchReportList - , brlKind - , brlItems - - -- ** BatchReportOutputsItem - , BatchReportOutputsItem - , batchReportOutputsItem - , broiFormat - , broiDownloadURL - , broiType - - -- ** BatchReportTimeSpan - , BatchReportTimeSpan - , batchReportTimeSpan - , brtsStartTime - , brtsEndTime - -- ** GroupItemListResponse , GroupItemListResponse , groupItemListResponse @@ -176,8 +126,6 @@ ) where import Network.Google.Prelude -import Network.Google.Resource.YouTubeAnalytics.BatchReportDefinitions.List -import Network.Google.Resource.YouTubeAnalytics.BatchReports.List import Network.Google.Resource.YouTubeAnalytics.GroupItems.Delete import Network.Google.Resource.YouTubeAnalytics.GroupItems.Insert import Network.Google.Resource.YouTubeAnalytics.GroupItems.List @@ -198,8 +146,6 @@ GroupsDeleteResource :<|> GroupsUpdateResource :<|> ReportsQueryResource - :<|> BatchReportsListResource :<|> GroupItemsInsertResource :<|> GroupItemsListResource :<|> GroupItemsDeleteResource - :<|> BatchReportDefinitionsListResource diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-analytics-0.1.1/gogol-youtube-analytics.cabal new/gogol-youtube-analytics-0.3.0/gogol-youtube-analytics.cabal --- old/gogol-youtube-analytics-0.1.1/gogol-youtube-analytics.cabal 2016-11-03 14:26:28.000000000 +0100 +++ new/gogol-youtube-analytics-0.3.0/gogol-youtube-analytics.cabal 2017-07-12 16:51:30.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-youtube-analytics -version: 0.1.1 +version: 0.3.0 synopsis: Google YouTube Analytics SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -33,9 +33,7 @@ ghc-options: -Wall exposed-modules: - Network.Google.Resource.YouTubeAnalytics.BatchReportDefinitions.List - , Network.Google.Resource.YouTubeAnalytics.BatchReports.List - , Network.Google.Resource.YouTubeAnalytics.GroupItems.Delete + Network.Google.Resource.YouTubeAnalytics.GroupItems.Delete , Network.Google.Resource.YouTubeAnalytics.GroupItems.Insert , Network.Google.Resource.YouTubeAnalytics.GroupItems.List , Network.Google.Resource.YouTubeAnalytics.Groups.Delete @@ -51,5 +49,5 @@ , Network.Google.YouTubeAnalytics.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-youtube for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-youtube for openSUSE:Factory checked in at 2017-08-31 20:55:26 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-youtube (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-youtube.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-youtube" Thu Aug 31 20:55:26 2017 rev:2 rq:513355 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-youtube/ghc-gogol-youtube.changes 2017-05-10 20:44:41.224209896 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-youtube.new/ghc-gogol-youtube.changes 2017-08-31 20:55:28.431759342 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:05:48 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-youtube-0.1.1.tar.gz New: ---- gogol-youtube-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-youtube.spec ++++++ --- /var/tmp/diff_new_pack.K0EC6m/_old 2017-08-31 20:55:29.411621669 +0200 +++ /var/tmp/diff_new_pack.K0EC6m/_new 2017-08-31 20:55:29.411621669 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-youtube Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google YouTube Data SDK License: MPL-2.0 ++++++ gogol-youtube-0.1.1.tar.gz -> gogol-youtube-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/README.md new/gogol-youtube-0.3.0/README.md --- old/gogol-youtube-0.1.1/README.md 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/README.md 2017-07-12 16:51:30.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gen/Network/Google/Resource/YouTube/PlayListItems/Delete.hs new/gogol-youtube-0.3.0/gen/Network/Google/Resource/YouTube/PlayListItems/Delete.hs --- old/gogol-youtube-0.1.1/gen/Network/Google/Resource/YouTube/PlayListItems/Delete.hs 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gen/Network/Google/Resource/YouTube/PlayListItems/Delete.hs 2017-07-12 16:51:30.000000000 +0200 @@ -33,6 +33,7 @@ , PlayListItemsDelete -- * Request Lenses + , plidOnBehalfOfContentOwner , plidId ) where @@ -46,28 +47,48 @@ "v3" :> "playlistItems" :> QueryParam "id" Text :> - QueryParam "alt" AltJSON :> Delete '[JSON] () + QueryParam "onBehalfOfContentOwner" Text :> + QueryParam "alt" AltJSON :> Delete '[JSON] () -- | Deletes a playlist item. -- -- /See:/ 'playListItemsDelete' smart constructor. -newtype PlayListItemsDelete = PlayListItemsDelete' - { _plidId :: Text +data PlayListItemsDelete = PlayListItemsDelete' + { _plidOnBehalfOfContentOwner :: !(Maybe Text) + , _plidId :: !Text } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'PlayListItemsDelete' with the minimum fields required to make a request. -- -- Use one of the following lenses to modify other fields as desired: -- +-- * 'plidOnBehalfOfContentOwner' +-- -- * 'plidId' playListItemsDelete :: Text -- ^ 'plidId' -> PlayListItemsDelete playListItemsDelete pPlidId_ = PlayListItemsDelete' - { _plidId = pPlidId_ + { _plidOnBehalfOfContentOwner = Nothing + , _plidId = pPlidId_ } +-- | Note: This parameter is intended exclusively for YouTube content +-- partners. The onBehalfOfContentOwner parameter indicates that the +-- request\'s authorization credentials identify a YouTube CMS user who is +-- acting on behalf of the content owner specified in the parameter value. +-- This parameter is intended for YouTube content partners that own and +-- manage many different YouTube channels. It allows content owners to +-- authenticate once and get access to all their video and channel data, +-- without having to provide authentication credentials for each individual +-- channel. The CMS account that the user authenticates with must be linked +-- to the specified YouTube content owner. +plidOnBehalfOfContentOwner :: Lens' PlayListItemsDelete (Maybe Text) +plidOnBehalfOfContentOwner + = lens _plidOnBehalfOfContentOwner + (\ s a -> s{_plidOnBehalfOfContentOwner = a}) + -- | The id parameter specifies the YouTube playlist item ID for the playlist -- item that is being deleted. In a playlistItem resource, the id property -- specifies the playlist item\'s ID. @@ -81,7 +102,9 @@ "https://www.googleapis.com/auth/youtube.force-ssl", "https://www.googleapis.com/auth/youtubepartner"] requestClient PlayListItemsDelete'{..} - = go (Just _plidId) (Just AltJSON) youTubeService + = go (Just _plidId) _plidOnBehalfOfContentOwner + (Just AltJSON) + youTubeService where go = buildClient (Proxy :: Proxy PlayListItemsDeleteResource) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gen/Network/Google/Resource/YouTube/PlayListItems/Update.hs new/gogol-youtube-0.3.0/gen/Network/Google/Resource/YouTube/PlayListItems/Update.hs --- old/gogol-youtube-0.1.1/gen/Network/Google/Resource/YouTube/PlayListItems/Update.hs 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gen/Network/Google/Resource/YouTube/PlayListItems/Update.hs 2017-07-12 16:51:30.000000000 +0200 @@ -36,6 +36,7 @@ -- * Request Lenses , pliuPart , pliuPayload + , pliuOnBehalfOfContentOwner ) where import Network.Google.Prelude @@ -48,17 +49,19 @@ "v3" :> "playlistItems" :> QueryParam "part" Text :> - QueryParam "alt" AltJSON :> - ReqBody '[JSON] PlayListItem :> - Put '[JSON] PlayListItem + QueryParam "onBehalfOfContentOwner" Text :> + QueryParam "alt" AltJSON :> + ReqBody '[JSON] PlayListItem :> + Put '[JSON] PlayListItem -- | Modifies a playlist item. For example, you could update the item\'s -- position in the playlist. -- -- /See:/ 'playListItemsUpdate' smart constructor. data PlayListItemsUpdate = PlayListItemsUpdate' - { _pliuPart :: !Text - , _pliuPayload :: !PlayListItem + { _pliuPart :: !Text + , _pliuPayload :: !PlayListItem + , _pliuOnBehalfOfContentOwner :: !(Maybe Text) } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'PlayListItemsUpdate' with the minimum fields required to make a request. @@ -68,6 +71,8 @@ -- * 'pliuPart' -- -- * 'pliuPayload' +-- +-- * 'pliuOnBehalfOfContentOwner' playListItemsUpdate :: Text -- ^ 'pliuPart' -> PlayListItem -- ^ 'pliuPayload' @@ -76,6 +81,7 @@ PlayListItemsUpdate' { _pliuPart = pPliuPart_ , _pliuPayload = pPliuPayload_ + , _pliuOnBehalfOfContentOwner = Nothing } -- | The part parameter serves two purposes in this operation. It identifies @@ -99,6 +105,21 @@ pliuPayload = lens _pliuPayload (\ s a -> s{_pliuPayload = a}) +-- | Note: This parameter is intended exclusively for YouTube content +-- partners. The onBehalfOfContentOwner parameter indicates that the +-- request\'s authorization credentials identify a YouTube CMS user who is +-- acting on behalf of the content owner specified in the parameter value. +-- This parameter is intended for YouTube content partners that own and +-- manage many different YouTube channels. It allows content owners to +-- authenticate once and get access to all their video and channel data, +-- without having to provide authentication credentials for each individual +-- channel. The CMS account that the user authenticates with must be linked +-- to the specified YouTube content owner. +pliuOnBehalfOfContentOwner :: Lens' PlayListItemsUpdate (Maybe Text) +pliuOnBehalfOfContentOwner + = lens _pliuOnBehalfOfContentOwner + (\ s a -> s{_pliuOnBehalfOfContentOwner = a}) + instance GoogleRequest PlayListItemsUpdate where type Rs PlayListItemsUpdate = PlayListItem type Scopes PlayListItemsUpdate = @@ -106,7 +127,9 @@ "https://www.googleapis.com/auth/youtube.force-ssl", "https://www.googleapis.com/auth/youtubepartner"] requestClient PlayListItemsUpdate'{..} - = go (Just _pliuPart) (Just AltJSON) _pliuPayload + = go (Just _pliuPart) _pliuOnBehalfOfContentOwner + (Just AltJSON) + _pliuPayload youTubeService where go = buildClient diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gen/Network/Google/Resource/YouTube/Videos/List.hs new/gogol-youtube-0.3.0/gen/Network/Google/Resource/YouTube/Videos/List.hs --- old/gogol-youtube-0.1.1/gen/Network/Google/Resource/YouTube/Videos/List.hs 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gen/Network/Google/Resource/YouTube/Videos/List.hs 2017-07-12 16:51:30.000000000 +0200 @@ -38,9 +38,11 @@ , vlRegionCode , vlLocale , vlMyRating + , vlMaxHeight , vlHl , vlOnBehalfOfContentOwner , vlVideoCategoryId + , vlMaxWidth , vlId , vlPageToken , vlMaxResults @@ -60,14 +62,16 @@ QueryParam "regionCode" Text :> QueryParam "locale" Text :> QueryParam "myRating" VideosListMyRating :> - QueryParam "hl" Text :> - QueryParam "onBehalfOfContentOwner" Text :> - QueryParam "videoCategoryId" Text :> - QueryParam "id" Text :> - QueryParam "pageToken" Text :> - QueryParam "maxResults" (Textual Word32) :> - QueryParam "alt" AltJSON :> - Get '[JSON] VideoListResponse + QueryParam "maxHeight" (Textual Word32) :> + QueryParam "hl" Text :> + QueryParam "onBehalfOfContentOwner" Text :> + QueryParam "videoCategoryId" Text :> + QueryParam "maxWidth" (Textual Word32) :> + QueryParam "id" Text :> + QueryParam "pageToken" Text :> + QueryParam "maxResults" (Textual Word32) :> + QueryParam "alt" AltJSON :> + Get '[JSON] VideoListResponse -- | Returns a list of videos that match the API request parameters. -- @@ -78,9 +82,11 @@ , _vlRegionCode :: !(Maybe Text) , _vlLocale :: !(Maybe Text) , _vlMyRating :: !(Maybe VideosListMyRating) + , _vlMaxHeight :: !(Maybe (Textual Word32)) , _vlHl :: !(Maybe Text) , _vlOnBehalfOfContentOwner :: !(Maybe Text) , _vlVideoCategoryId :: !Text + , _vlMaxWidth :: !(Maybe (Textual Word32)) , _vlId :: !(Maybe Text) , _vlPageToken :: !(Maybe Text) , _vlMaxResults :: !(Textual Word32) @@ -100,12 +106,16 @@ -- -- * 'vlMyRating' -- +-- * 'vlMaxHeight' +-- -- * 'vlHl' -- -- * 'vlOnBehalfOfContentOwner' -- -- * 'vlVideoCategoryId' -- +-- * 'vlMaxWidth' +-- -- * 'vlId' -- -- * 'vlPageToken' @@ -121,9 +131,11 @@ , _vlRegionCode = Nothing , _vlLocale = Nothing , _vlMyRating = Nothing + , _vlMaxHeight = Nothing , _vlHl = Nothing , _vlOnBehalfOfContentOwner = Nothing , _vlVideoCategoryId = "0" + , _vlMaxWidth = Nothing , _vlId = Nothing , _vlPageToken = Nothing , _vlMaxResults = 5 @@ -161,6 +173,14 @@ vlMyRating = lens _vlMyRating (\ s a -> s{_vlMyRating = a}) +-- | The maxHeight parameter specifies a maximum height of the embedded +-- player. If maxWidth is provided, maxHeight may not be reached in order +-- to not violate the width request. +vlMaxHeight :: Lens' VideosList (Maybe Word32) +vlMaxHeight + = lens _vlMaxHeight (\ s a -> s{_vlMaxHeight = a}) . + mapping _Coerce + -- | The hl parameter instructs the API to retrieve localized resource -- metadata for a specific application language that the YouTube website -- supports. The parameter value must be a language code included in the @@ -196,6 +216,14 @@ = lens _vlVideoCategoryId (\ s a -> s{_vlVideoCategoryId = a}) +-- | The maxWidth parameter specifies a maximum width of the embedded player. +-- If maxHeight is provided, maxWidth may not be reached in order to not +-- violate the height request. +vlMaxWidth :: Lens' VideosList (Maybe Word32) +vlMaxWidth + = lens _vlMaxWidth (\ s a -> s{_vlMaxWidth = a}) . + mapping _Coerce + -- | The id parameter specifies a comma-separated list of the YouTube video -- ID(s) for the resource(s) that are being retrieved. In a video resource, -- the id property specifies the video\'s ID. @@ -206,16 +234,16 @@ -- that should be returned. In an API response, the nextPageToken and -- prevPageToken properties identify other pages that could be retrieved. -- Note: This parameter is supported for use in conjunction with the --- myRating parameter, but it is not supported for use in conjunction with --- the id parameter. +-- myRating and chart parameters, but it is not supported for use in +-- conjunction with the id parameter. vlPageToken :: Lens' VideosList (Maybe Text) vlPageToken = lens _vlPageToken (\ s a -> s{_vlPageToken = a}) -- | The maxResults parameter specifies the maximum number of items that -- should be returned in the result set. Note: This parameter is supported --- for use in conjunction with the myRating parameter, but it is not --- supported for use in conjunction with the id parameter. +-- for use in conjunction with the myRating and chart parameters, but it is +-- not supported for use in conjunction with the id parameter. vlMaxResults :: Lens' VideosList Word32 vlMaxResults = lens _vlMaxResults (\ s a -> s{_vlMaxResults = a}) @@ -231,9 +259,11 @@ requestClient VideosList'{..} = go (Just _vlPart) _vlChart _vlRegionCode _vlLocale _vlMyRating + _vlMaxHeight _vlHl _vlOnBehalfOfContentOwner (Just _vlVideoCategoryId) + _vlMaxWidth _vlId _vlPageToken (Just _vlMaxResults) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gen/Network/Google/YouTube/Types/Product.hs new/gogol-youtube-0.3.0/gen/Network/Google/YouTube/Types/Product.hs --- old/gogol-youtube-0.1.1/gen/Network/Google/YouTube/Types/Product.hs 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gen/Network/Google/YouTube/Types/Product.hs 2017-07-12 16:51:30.000000000 +0200 @@ -2469,6 +2469,7 @@ -- /See:/ 'videoContentDetails' smart constructor. data VideoContentDetails = VideoContentDetails' { _vcdCountryRestriction :: !(Maybe AccessPolicy) + , _vcdHasCustomThumbnail :: !(Maybe Bool) , _vcdDefinition :: !(Maybe VideoContentDetailsDefinition) , _vcdDimension :: !(Maybe Text) , _vcdCaption :: !(Maybe VideoContentDetailsCaption) @@ -2485,6 +2486,8 @@ -- -- * 'vcdCountryRestriction' -- +-- * 'vcdHasCustomThumbnail' +-- -- * 'vcdDefinition' -- -- * 'vcdDimension' @@ -2505,6 +2508,7 @@ videoContentDetails = VideoContentDetails' { _vcdCountryRestriction = Nothing + , _vcdHasCustomThumbnail = Nothing , _vcdDefinition = Nothing , _vcdDimension = Nothing , _vcdCaption = Nothing @@ -2522,6 +2526,14 @@ = lens _vcdCountryRestriction (\ s a -> s{_vcdCountryRestriction = a}) +-- | Indicates whether the video uploader has provided a custom thumbnail +-- image for the video. This property is only visible to the video +-- uploader. +vcdHasCustomThumbnail :: Lens' VideoContentDetails (Maybe Bool) +vcdHasCustomThumbnail + = lens _vcdHasCustomThumbnail + (\ s a -> s{_vcdHasCustomThumbnail = a}) + -- | The value of definition indicates whether the video is available in high -- definition or only in standard definition. vcdDefinition :: Lens' VideoContentDetails (Maybe VideoContentDetailsDefinition) @@ -2585,7 +2597,9 @@ = withObject "VideoContentDetails" (\ o -> VideoContentDetails' <$> - (o .:? "countryRestriction") <*> (o .:? "definition") + (o .:? "countryRestriction") <*> + (o .:? "hasCustomThumbnail") + <*> (o .:? "definition") <*> (o .:? "dimension") <*> (o .:? "caption") <*> (o .:? "regionRestriction") @@ -2600,6 +2614,7 @@ (catMaybes [("countryRestriction" .=) <$> _vcdCountryRestriction, + ("hasCustomThumbnail" .=) <$> _vcdHasCustomThumbnail, ("definition" .=) <$> _vcdDefinition, ("dimension" .=) <$> _vcdDimension, ("caption" .=) <$> _vcdCaption, @@ -3645,16 +3660,15 @@ -- -- /See:/ 'videoFileDetails' smart constructor. data VideoFileDetails = VideoFileDetails' - { _vfdBitrateBps :: !(Maybe (Textual Word64)) - , _vfdCreationTime :: !(Maybe Text) - , _vfdRecordingLocation :: !(Maybe GeoPoint) - , _vfdDurationMs :: !(Maybe (Textual Word64)) - , _vfdFileSize :: !(Maybe (Textual Word64)) - , _vfdFileType :: !(Maybe VideoFileDetailsFileType) - , _vfdContainer :: !(Maybe Text) - , _vfdVideoStreams :: !(Maybe [VideoFileDetailsVideoStream]) - , _vfdAudioStreams :: !(Maybe [VideoFileDetailsAudioStream]) - , _vfdFileName :: !(Maybe Text) + { _vfdBitrateBps :: !(Maybe (Textual Word64)) + , _vfdCreationTime :: !(Maybe Text) + , _vfdDurationMs :: !(Maybe (Textual Word64)) + , _vfdFileSize :: !(Maybe (Textual Word64)) + , _vfdFileType :: !(Maybe VideoFileDetailsFileType) + , _vfdContainer :: !(Maybe Text) + , _vfdVideoStreams :: !(Maybe [VideoFileDetailsVideoStream]) + , _vfdAudioStreams :: !(Maybe [VideoFileDetailsAudioStream]) + , _vfdFileName :: !(Maybe Text) } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'VideoFileDetails' with the minimum fields required to make a request. @@ -3665,8 +3679,6 @@ -- -- * 'vfdCreationTime' -- --- * 'vfdRecordingLocation' --- -- * 'vfdDurationMs' -- -- * 'vfdFileSize' @@ -3686,7 +3698,6 @@ VideoFileDetails' { _vfdBitrateBps = Nothing , _vfdCreationTime = Nothing - , _vfdRecordingLocation = Nothing , _vfdDurationMs = Nothing , _vfdFileSize = Nothing , _vfdFileType = Nothing @@ -3713,13 +3724,6 @@ = lens _vfdCreationTime (\ s a -> s{_vfdCreationTime = a}) --- | Geographic coordinates that identify the place where the uploaded video --- was recorded. Coordinates are defined using WGS 84. -vfdRecordingLocation :: Lens' VideoFileDetails (Maybe GeoPoint) -vfdRecordingLocation - = lens _vfdRecordingLocation - (\ s a -> s{_vfdRecordingLocation = a}) - -- | The length of the uploaded video in milliseconds. vfdDurationMs :: Lens' VideoFileDetails (Maybe Word64) vfdDurationMs @@ -3776,8 +3780,7 @@ (\ o -> VideoFileDetails' <$> (o .:? "bitrateBps") <*> (o .:? "creationTime") <*> - (o .:? "recordingLocation") - <*> (o .:? "durationMs") + (o .:? "durationMs") <*> (o .:? "fileSize") <*> (o .:? "fileType") <*> (o .:? "container") @@ -3791,7 +3794,6 @@ (catMaybes [("bitrateBps" .=) <$> _vfdBitrateBps, ("creationTime" .=) <$> _vfdCreationTime, - ("recordingLocation" .=) <$> _vfdRecordingLocation, ("durationMs" .=) <$> _vfdDurationMs, ("fileSize" .=) <$> _vfdFileSize, ("fileType" .=) <$> _vfdFileType, @@ -4013,9 +4015,8 @@ -- | Details about the content of a channel. -- -- /See:/ 'channelContentDetails' smart constructor. -data ChannelContentDetails = ChannelContentDetails' - { _ccdRelatedPlayLists :: !(Maybe ChannelContentDetailsRelatedPlayLists) - , _ccdGooglePlusUserId :: !(Maybe Text) +newtype ChannelContentDetails = ChannelContentDetails' + { _ccdRelatedPlayLists :: Maybe ChannelContentDetailsRelatedPlayLists } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'ChannelContentDetails' with the minimum fields required to make a request. @@ -4023,14 +4024,11 @@ -- Use one of the following lenses to modify other fields as desired: -- -- * 'ccdRelatedPlayLists' --- --- * 'ccdGooglePlusUserId' channelContentDetails :: ChannelContentDetails channelContentDetails = ChannelContentDetails' { _ccdRelatedPlayLists = Nothing - , _ccdGooglePlusUserId = Nothing } ccdRelatedPlayLists :: Lens' ChannelContentDetails (Maybe ChannelContentDetailsRelatedPlayLists) @@ -4038,27 +4036,18 @@ = lens _ccdRelatedPlayLists (\ s a -> s{_ccdRelatedPlayLists = a}) --- | The googlePlusUserId object identifies the Google+ profile ID associated --- with this channel. -ccdGooglePlusUserId :: Lens' ChannelContentDetails (Maybe Text) -ccdGooglePlusUserId - = lens _ccdGooglePlusUserId - (\ s a -> s{_ccdGooglePlusUserId = a}) - instance FromJSON ChannelContentDetails where parseJSON = withObject "ChannelContentDetails" (\ o -> ChannelContentDetails' <$> - (o .:? "relatedPlaylists") <*> - (o .:? "googlePlusUserId")) + (o .:? "relatedPlaylists")) instance ToJSON ChannelContentDetails where toJSON ChannelContentDetails'{..} = object (catMaybes - [("relatedPlaylists" .=) <$> _ccdRelatedPlayLists, - ("googlePlusUserId" .=) <$> _ccdGooglePlusUserId]) + [("relatedPlaylists" .=) <$> _ccdRelatedPlayLists]) -- | Details about a resource which was added to a channel. -- @@ -10091,22 +10080,42 @@ -- | Player to be used for a video playback. -- -- /See:/ 'videoPlayer' smart constructor. -newtype VideoPlayer = VideoPlayer' - { _vpEmbedHTML :: Maybe Text +data VideoPlayer = VideoPlayer' + { _vpEmbedHeight :: !(Maybe (Textual Int64)) + , _vpEmbedWidth :: !(Maybe (Textual Int64)) + , _vpEmbedHTML :: !(Maybe Text) } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'VideoPlayer' with the minimum fields required to make a request. -- -- Use one of the following lenses to modify other fields as desired: -- +-- * 'vpEmbedHeight' +-- +-- * 'vpEmbedWidth' +-- -- * 'vpEmbedHTML' videoPlayer :: VideoPlayer videoPlayer = VideoPlayer' - { _vpEmbedHTML = Nothing + { _vpEmbedHeight = Nothing + , _vpEmbedWidth = Nothing + , _vpEmbedHTML = Nothing } +vpEmbedHeight :: Lens' VideoPlayer (Maybe Int64) +vpEmbedHeight + = lens _vpEmbedHeight + (\ s a -> s{_vpEmbedHeight = a}) + . mapping _Coerce + +-- | The embed width +vpEmbedWidth :: Lens' VideoPlayer (Maybe Int64) +vpEmbedWidth + = lens _vpEmbedWidth (\ s a -> s{_vpEmbedWidth = a}) + . mapping _Coerce + -- | An -- tag that embeds a player that will play the video. vpEmbedHTML :: Lens' VideoPlayer (Maybe Text) @@ -10116,12 +10125,18 @@ instance FromJSON VideoPlayer where parseJSON = withObject "VideoPlayer" - (\ o -> VideoPlayer' <$> (o .:? "embedHtml")) + (\ o -> + VideoPlayer' <$> + (o .:? "embedHeight") <*> (o .:? "embedWidth") <*> + (o .:? "embedHtml")) instance ToJSON VideoPlayer where toJSON VideoPlayer'{..} = object - (catMaybes [("embedHtml" .=) <$> _vpEmbedHTML]) + (catMaybes + [("embedHeight" .=) <$> _vpEmbedHeight, + ("embedWidth" .=) <$> _vpEmbedWidth, + ("embedHtml" .=) <$> _vpEmbedHTML]) -- | Describes a single promoted item id. It is a union of various possible -- types. @@ -10944,7 +10959,7 @@ { _ibImageURL :: !(Maybe Text) , _ibTargetChannelId :: !(Maybe Text) , _ibTiming :: !(Maybe InvideoTiming) - , _ibImageBytes :: !(Maybe Base64) + , _ibImageBytes :: !(Maybe Bytes) , _ibPosition :: !(Maybe InvideoPosition) } deriving (Eq,Show,Data,Typeable,Generic) @@ -10987,7 +11002,7 @@ ibImageBytes :: Lens' InvideoBranding (Maybe ByteString) ibImageBytes = lens _ibImageBytes (\ s a -> s{_ibImageBytes = a}) - . mapping _Base64 + . mapping _Bytes ibPosition :: Lens' InvideoBranding (Maybe InvideoPosition) ibPosition @@ -11845,10 +11860,11 @@ -- -- /See:/ 'playListItemContentDetails' smart constructor. data PlayListItemContentDetails = PlayListItemContentDetails' - { _plicdStartAt :: !(Maybe Text) - , _plicdNote :: !(Maybe Text) - , _plicdVideoId :: !(Maybe Text) - , _plicdEndAt :: !(Maybe Text) + { _plicdStartAt :: !(Maybe Text) + , _plicdNote :: !(Maybe Text) + , _plicdVideoPublishedAt :: !(Maybe DateTime') + , _plicdVideoId :: !(Maybe Text) + , _plicdEndAt :: !(Maybe Text) } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'PlayListItemContentDetails' with the minimum fields required to make a request. @@ -11859,6 +11875,8 @@ -- -- * 'plicdNote' -- +-- * 'plicdVideoPublishedAt' +-- -- * 'plicdVideoId' -- -- * 'plicdEndAt' @@ -11868,6 +11886,7 @@ PlayListItemContentDetails' { _plicdStartAt = Nothing , _plicdNote = Nothing + , _plicdVideoPublishedAt = Nothing , _plicdVideoId = Nothing , _plicdEndAt = Nothing } @@ -11885,6 +11904,14 @@ plicdNote = lens _plicdNote (\ s a -> s{_plicdNote = a}) +-- | The date and time that the video was published to YouTube. The value is +-- specified in ISO 8601 (YYYY-MM-DDThh:mm:ss.sZ) format. +plicdVideoPublishedAt :: Lens' PlayListItemContentDetails (Maybe UTCTime) +plicdVideoPublishedAt + = lens _plicdVideoPublishedAt + (\ s a -> s{_plicdVideoPublishedAt = a}) + . mapping _DateTime + -- | The ID that YouTube uses to uniquely identify a video. To retrieve the -- video resource, set the id query parameter to this value in your API -- request. @@ -11907,7 +11934,8 @@ (\ o -> PlayListItemContentDetails' <$> (o .:? "startAt") <*> (o .:? "note") <*> - (o .:? "videoId") + (o .:? "videoPublishedAt") + <*> (o .:? "videoId") <*> (o .:? "endAt")) instance ToJSON PlayListItemContentDetails where @@ -11916,6 +11944,7 @@ (catMaybes [("startAt" .=) <$> _plicdStartAt, ("note" .=) <$> _plicdNote, + ("videoPublishedAt" .=) <$> _plicdVideoPublishedAt, ("videoId" .=) <$> _plicdVideoId, ("endAt" .=) <$> _plicdEndAt]) @@ -13000,22 +13029,21 @@ -- -- /See:/ 'commentSnippet' smart constructor. data CommentSnippet = CommentSnippet' - { _cViewerRating :: !(Maybe CommentSnippetViewerRating) - , _cPublishedAt :: !(Maybe DateTime') - , _cAuthorChannelURL :: !(Maybe Text) - , _cModerationStatus :: !(Maybe CommentSnippetModerationStatus) - , _cLikeCount :: !(Maybe (Textual Word32)) - , _cChannelId :: !(Maybe Text) - , _cTextOriginal :: !(Maybe Text) - , _cVideoId :: !(Maybe Text) - , _cTextDisplay :: !(Maybe Text) - , _cAuthorProFileImageURL :: !(Maybe Text) - , _cAuthorDisplayName :: !(Maybe Text) - , _cUpdatedAt :: !(Maybe DateTime') - , _cAuthorChannelId :: !(Maybe JSONValue) - , _cCanRate :: !(Maybe Bool) - , _cAuthorGoogleplusProFileURL :: !(Maybe Text) - , _cParentId :: !(Maybe Text) + { _cViewerRating :: !(Maybe CommentSnippetViewerRating) + , _cPublishedAt :: !(Maybe DateTime') + , _cAuthorChannelURL :: !(Maybe Text) + , _cModerationStatus :: !(Maybe CommentSnippetModerationStatus) + , _cLikeCount :: !(Maybe (Textual Word32)) + , _cChannelId :: !(Maybe Text) + , _cTextOriginal :: !(Maybe Text) + , _cVideoId :: !(Maybe Text) + , _cTextDisplay :: !(Maybe Text) + , _cAuthorProFileImageURL :: !(Maybe Text) + , _cAuthorDisplayName :: !(Maybe Text) + , _cUpdatedAt :: !(Maybe DateTime') + , _cAuthorChannelId :: !(Maybe JSONValue) + , _cCanRate :: !(Maybe Bool) + , _cParentId :: !(Maybe Text) } deriving (Eq,Show,Data,Typeable,Generic) -- | Creates a value of 'CommentSnippet' with the minimum fields required to make a request. @@ -13050,8 +13078,6 @@ -- -- * 'cCanRate' -- --- * 'cAuthorGoogleplusProFileURL' --- -- * 'cParentId' commentSnippet :: CommentSnippet @@ -13071,7 +13097,6 @@ , _cUpdatedAt = Nothing , _cAuthorChannelId = Nothing , _cCanRate = Nothing - , _cAuthorGoogleplusProFileURL = Nothing , _cParentId = Nothing } @@ -13165,12 +13190,6 @@ cCanRate :: Lens' CommentSnippet (Maybe Bool) cCanRate = lens _cCanRate (\ s a -> s{_cCanRate = a}) --- | Link to the author\'s Google+ profile, if any. -cAuthorGoogleplusProFileURL :: Lens' CommentSnippet (Maybe Text) -cAuthorGoogleplusProFileURL - = lens _cAuthorGoogleplusProFileURL - (\ s a -> s{_cAuthorGoogleplusProFileURL = a}) - -- | The unique id of the parent comment, only set for replies. cParentId :: Lens' CommentSnippet (Maybe Text) cParentId @@ -13194,7 +13213,6 @@ <*> (o .:? "updatedAt") <*> (o .:? "authorChannelId") <*> (o .:? "canRate") - <*> (o .:? "authorGoogleplusProfileUrl") <*> (o .:? "parentId")) instance ToJSON CommentSnippet where @@ -13216,8 +13234,6 @@ ("updatedAt" .=) <$> _cUpdatedAt, ("authorChannelId" .=) <$> _cAuthorChannelId, ("canRate" .=) <$> _cCanRate, - ("authorGoogleplusProfileUrl" .=) <$> - _cAuthorGoogleplusProFileURL, ("parentId" .=) <$> _cParentId]) -- | Brief description of the live stream status. @@ -13555,7 +13571,7 @@ = object (catMaybes [("tags" .=) <$> _vpdTags]) -- | Ratings schemes. The country-specific ratings are mostly for movies and --- shows. NEXT_ID: 68 +-- shows. NEXT_ID: 69 -- -- /See:/ 'contentRating' smart constructor. data ContentRating = ContentRating' @@ -13581,6 +13597,7 @@ , _crSmsaRating :: !(Maybe ContentRatingSmsaRating) , _crChvrsRating :: !(Maybe ContentRatingChvrsRating) , _crIncaaRating :: !(Maybe ContentRatingIncaaRating) + , _crMcstRating :: !(Maybe ContentRatingMcstRating) , _crNfrcRating :: !(Maybe ContentRatingNfrcRating) , _crCsaRating :: !(Maybe ContentRatingCsaRating) , _crMocRating :: !(Maybe ContentRatingMocRating) @@ -13676,6 +13693,8 @@ -- -- * 'crIncaaRating' -- +-- * 'crMcstRating' +-- -- * 'crNfrcRating' -- -- * 'crCsaRating' @@ -13791,6 +13810,7 @@ , _crSmsaRating = Nothing , _crChvrsRating = Nothing , _crIncaaRating = Nothing + , _crMcstRating = Nothing , _crNfrcRating = Nothing , _crCsaRating = Nothing , _crMocRating = Nothing @@ -13978,6 +13998,11 @@ = lens _crIncaaRating (\ s a -> s{_crIncaaRating = a}) +-- | The video\'s rating system for Vietnam - MCST +crMcstRating :: Lens' ContentRating (Maybe ContentRatingMcstRating) +crMcstRating + = lens _crMcstRating (\ s a -> s{_crMcstRating = a}) + -- | The video\'s rating from the Bulgarian National Film Center. crNfrcRating :: Lens' ContentRating (Maybe ContentRatingNfrcRating) crNfrcRating @@ -14275,6 +14300,7 @@ <*> (o .:? "smsaRating") <*> (o .:? "chvrsRating") <*> (o .:? "incaaRating") + <*> (o .:? "mcstRating") <*> (o .:? "nfrcRating") <*> (o .:? "csaRating") <*> (o .:? "mocRating") @@ -14347,6 +14373,7 @@ ("smsaRating" .=) <$> _crSmsaRating, ("chvrsRating" .=) <$> _crChvrsRating, ("incaaRating" .=) <$> _crIncaaRating, + ("mcstRating" .=) <$> _crMcstRating, ("nfrcRating" .=) <$> _crNfrcRating, ("csaRating" .=) <$> _crCsaRating, ("mocRating" .=) <$> _crMocRating, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gen/Network/Google/YouTube/Types/Sum.hs new/gogol-youtube-0.3.0/gen/Network/Google/YouTube/Types/Sum.hs --- old/gogol-youtube-0.1.1/gen/Network/Google/YouTube/Types/Sum.hs 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gen/Network/Google/YouTube/Types/Sum.hs 2017-07-12 16:51:30.000000000 +0200 @@ -915,6 +915,8 @@ -- ^ @1080p@ | CSR1440p -- ^ @1440p@ + | CSR2160p + -- ^ @2160p@ | CSR240p -- ^ @240p@ | CSR360p @@ -931,6 +933,7 @@ parseQueryParam = \case "1080p" -> Right CSR1080p "1440p" -> Right CSR1440p + "2160p" -> Right CSR2160p "240p" -> Right CSR240p "360p" -> Right CSR360p "480p" -> Right CSR480p @@ -941,6 +944,7 @@ toQueryParam = \case CSR1080p -> "1080p" CSR1440p -> "1440p" + CSR2160p -> "2160p" CSR240p -> "240p" CSR360p -> "360p" CSR480p -> "480p" @@ -4920,6 +4924,10 @@ data VideoSuggestionsProcessingHintsItem = NonStreamableMov -- ^ @nonStreamableMov@ + | ProcsesingHintSpatialAudio + -- ^ @procsesingHintSpatialAudio@ + | ProcsesingHintSphericalVideo + -- ^ @procsesingHintSphericalVideo@ | SendBestQualityVideo -- ^ @sendBestQualityVideo@ deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) @@ -4929,12 +4937,16 @@ instance FromHttpApiData VideoSuggestionsProcessingHintsItem where parseQueryParam = \case "nonStreamableMov" -> Right NonStreamableMov + "procsesingHintSpatialAudio" -> Right ProcsesingHintSpatialAudio + "procsesingHintSphericalVideo" -> Right ProcsesingHintSphericalVideo "sendBestQualityVideo" -> Right SendBestQualityVideo x -> Left ("Unable to parse VideoSuggestionsProcessingHintsItem from: " <> x) instance ToHttpApiData VideoSuggestionsProcessingHintsItem where toQueryParam = \case NonStreamableMov -> "nonStreamableMov" + ProcsesingHintSpatialAudio -> "procsesingHintSpatialAudio" + ProcsesingHintSphericalVideo -> "procsesingHintSphericalVideo" SendBestQualityVideo -> "sendBestQualityVideo" instance FromJSON VideoSuggestionsProcessingHintsItem where @@ -5135,6 +5147,57 @@ instance ToJSON SearchListVideoEmbeddable where toJSON = toJSONText +-- | The video\'s rating system for Vietnam - MCST +data ContentRatingMcstRating + = MCST0 + -- ^ @mcst0@ + | Mcst16plus + -- ^ @mcst16plus@ + | MCSTC13 + -- ^ @mcstC13@ + | MCSTC16 + -- ^ @mcstC16@ + | MCSTC18 + -- ^ @mcstC18@ + | McstGPg + -- ^ @mcstGPg@ + | McstP + -- ^ @mcstP@ + | McstUnrated + -- ^ @mcstUnrated@ + deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) + +instance Hashable ContentRatingMcstRating + +instance FromHttpApiData ContentRatingMcstRating where + parseQueryParam = \case + "mcst0" -> Right MCST0 + "mcst16plus" -> Right Mcst16plus + "mcstC13" -> Right MCSTC13 + "mcstC16" -> Right MCSTC16 + "mcstC18" -> Right MCSTC18 + "mcstGPg" -> Right McstGPg + "mcstP" -> Right McstP + "mcstUnrated" -> Right McstUnrated + x -> Left ("Unable to parse ContentRatingMcstRating from: " <> x) + +instance ToHttpApiData ContentRatingMcstRating where + toQueryParam = \case + MCST0 -> "mcst0" + Mcst16plus -> "mcst16plus" + MCSTC13 -> "mcstC13" + MCSTC16 -> "mcstC16" + MCSTC18 -> "mcstC18" + McstGPg -> "mcstGPg" + McstP -> "mcstP" + McstUnrated -> "mcstUnrated" + +instance FromJSON ContentRatingMcstRating where + parseJSON = parseJSONText "ContentRatingMcstRating" + +instance ToJSON ContentRatingMcstRating where + toJSON = toJSONText + -- | The eventType parameter restricts a search to broadcast events. If you -- specify a value for this parameter, you must also set the type -- parameter\'s value to video. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gen/Network/Google/YouTube/Types.hs new/gogol-youtube-0.3.0/gen/Network/Google/YouTube/Types.hs --- old/gogol-youtube-0.1.1/gen/Network/Google/YouTube/Types.hs 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gen/Network/Google/YouTube/Types.hs 2017-07-12 16:51:30.000000000 +0200 @@ -374,6 +374,7 @@ , VideoContentDetails , videoContentDetails , vcdCountryRestriction + , vcdHasCustomThumbnail , vcdDefinition , vcdDimension , vcdCaption @@ -525,7 +526,6 @@ , videoFileDetails , vfdBitrateBps , vfdCreationTime - , vfdRecordingLocation , vfdDurationMs , vfdFileSize , vfdFileType @@ -563,7 +563,6 @@ , ChannelContentDetails , channelContentDetails , ccdRelatedPlayLists - , ccdGooglePlusUserId -- * SearchListVideoDefinition , SearchListVideoDefinition (..) @@ -1385,6 +1384,8 @@ -- * VideoPlayer , VideoPlayer , videoPlayer + , vpEmbedHeight + , vpEmbedWidth , vpEmbedHTML -- * PromotedItemId @@ -1644,6 +1645,7 @@ , playListItemContentDetails , plicdStartAt , plicdNote + , plicdVideoPublishedAt , plicdVideoId , plicdEndAt @@ -1672,6 +1674,9 @@ -- * SearchListVideoEmbeddable , SearchListVideoEmbeddable (..) + -- * ContentRatingMcstRating + , ContentRatingMcstRating (..) + -- * LanguageTag , LanguageTag , languageTag @@ -1841,7 +1846,6 @@ , cUpdatedAt , cAuthorChannelId , cCanRate - , cAuthorGoogleplusProFileURL , cParentId -- * LiveStreamStatus @@ -1908,6 +1912,7 @@ , crSmsaRating , crChvrsRating , crIncaaRating + , crMcstRating , crNfrcRating , crCsaRating , crMocRating diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gen/Network/Google/YouTube.hs new/gogol-youtube-0.3.0/gen/Network/Google/YouTube.hs --- old/gogol-youtube-0.1.1/gen/Network/Google/YouTube.hs 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gen/Network/Google/YouTube.hs 2017-07-12 16:51:30.000000000 +0200 @@ -597,6 +597,7 @@ , VideoContentDetails , videoContentDetails , vcdCountryRestriction + , vcdHasCustomThumbnail , vcdDefinition , vcdDimension , vcdCaption @@ -748,7 +749,6 @@ , videoFileDetails , vfdBitrateBps , vfdCreationTime - , vfdRecordingLocation , vfdDurationMs , vfdFileSize , vfdFileType @@ -786,7 +786,6 @@ , ChannelContentDetails , channelContentDetails , ccdRelatedPlayLists - , ccdGooglePlusUserId -- ** SearchListVideoDefinition , SearchListVideoDefinition (..) @@ -1608,6 +1607,8 @@ -- ** VideoPlayer , VideoPlayer , videoPlayer + , vpEmbedHeight + , vpEmbedWidth , vpEmbedHTML -- ** PromotedItemId @@ -1867,6 +1868,7 @@ , playListItemContentDetails , plicdStartAt , plicdNote + , plicdVideoPublishedAt , plicdVideoId , plicdEndAt @@ -1895,6 +1897,9 @@ -- ** SearchListVideoEmbeddable , SearchListVideoEmbeddable (..) + -- ** ContentRatingMcstRating + , ContentRatingMcstRating (..) + -- ** LanguageTag , LanguageTag , languageTag @@ -2064,7 +2069,6 @@ , cUpdatedAt , cAuthorChannelId , cCanRate - , cAuthorGoogleplusProFileURL , cParentId -- ** LiveStreamStatus @@ -2131,6 +2135,7 @@ , crSmsaRating , crChvrsRating , crIncaaRating + , crMcstRating , crNfrcRating , crCsaRating , crMocRating diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-youtube-0.1.1/gogol-youtube.cabal new/gogol-youtube-0.3.0/gogol-youtube.cabal --- old/gogol-youtube-0.1.1/gogol-youtube.cabal 2016-11-03 14:26:29.000000000 +0100 +++ new/gogol-youtube-0.3.0/gogol-youtube.cabal 2017-07-12 16:51:30.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-youtube -version: 0.1.1 +version: 0.3.0 synopsis: Google YouTube Data SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -113,5 +113,5 @@ , Network.Google.YouTube.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-webmaster-tools for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-webmaster-tools for openSUSE:Factory checked in at 2017-08-31 20:55:23 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-webmaster-tools (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-webmaster-tools.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-webmaster-tools" Thu Aug 31 20:55:23 2017 rev:2 rq:513354 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-webmaster-tools/ghc-gogol-webmaster-tools.changes 2017-05-10 20:44:33.465304689 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-webmaster-tools.new/ghc-gogol-webmaster-tools.changes 2017-08-31 20:55:26.444038624 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:01 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-webmaster-tools-0.1.1.tar.gz New: ---- gogol-webmaster-tools-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-webmaster-tools.spec ++++++ --- /var/tmp/diff_new_pack.FGPSR3/_old 2017-08-31 20:55:27.363909379 +0200 +++ /var/tmp/diff_new_pack.FGPSR3/_new 2017-08-31 20:55:27.367908817 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-webmaster-tools Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google Search Console SDK License: MPL-2.0 ++++++ gogol-webmaster-tools-0.1.1.tar.gz -> gogol-webmaster-tools-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-webmaster-tools-0.1.1/README.md new/gogol-webmaster-tools-0.3.0/README.md --- old/gogol-webmaster-tools-0.1.1/README.md 2016-11-03 14:26:27.000000000 +0100 +++ new/gogol-webmaster-tools-0.3.0/README.md 2017-07-12 16:45:06.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-webmaster-tools-0.1.1/gogol-webmaster-tools.cabal new/gogol-webmaster-tools-0.3.0/gogol-webmaster-tools.cabal --- old/gogol-webmaster-tools-0.1.1/gogol-webmaster-tools.cabal 2016-11-03 14:26:27.000000000 +0100 +++ new/gogol-webmaster-tools-0.3.0/gogol-webmaster-tools.cabal 2017-07-12 16:45:06.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-webmaster-tools -version: 0.1.1 +version: 0.3.0 synopsis: Google Search Console SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -54,5 +54,5 @@ , Network.Google.WebmasterTools.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-vision for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-vision for openSUSE:Factory checked in at 2017-08-31 20:55:21 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-vision (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-vision.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-vision" Thu Aug 31 20:55:21 2017 rev:2 rq:513353 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-vision/ghc-gogol-vision.changes 2017-05-10 20:44:31.489583466 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-vision.new/ghc-gogol-vision.changes 2017-08-31 20:55:23.428462323 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:49 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-vision-0.1.1.tar.gz New: ---- gogol-vision-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-vision.spec ++++++ --- /var/tmp/diff_new_pack.h1ikue/_old 2017-08-31 20:55:24.596298238 +0200 +++ /var/tmp/diff_new_pack.h1ikue/_new 2017-08-31 20:55:24.624294305 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-vision Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google Cloud Vision SDK License: MPL-2.0 ++++++ gogol-vision-0.1.1.tar.gz -> gogol-vision-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-vision-0.1.1/README.md new/gogol-vision-0.3.0/README.md --- old/gogol-vision-0.1.1/README.md 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-vision-0.3.0/README.md 2017-07-12 16:45:05.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-vision-0.1.1/gen/Network/Google/Vision/Types/Product.hs new/gogol-vision-0.3.0/gen/Network/Google/Vision/Types/Product.hs --- old/gogol-vision-0.1.1/gen/Network/Google/Vision/Types/Product.hs 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-vision-0.3.0/gen/Network/Google/Vision/Types/Product.hs 2017-07-12 16:45:05.000000000 +0200 @@ -44,7 +44,9 @@ -- NormalizeLatLng(-180.0, 10.0) assert (0.0, -170.0) == -- NormalizeLatLng(180.0, 10.0) assert (-90.0, 10.0) == -- NormalizeLatLng(270.0, 10.0) assert (90.0, 10.0) == --- NormalizeLatLng(-270.0, 10.0) +-- NormalizeLatLng(-270.0, 10.0) The code in +-- logs\/storage\/validator\/logs_validator_traits.cc treats this type as +-- if it were annotated as ST_LOCATION. -- -- /See:/ 'latLng' smart constructor. data LatLng = LatLng' @@ -93,10 +95,10 @@ [("latitude" .=) <$> _llLatitude, ("longitude" .=) <$> _llLongitude]) --- | The /Feature/ indicates what type of image detection task to perform. --- Users describe the type of Google Cloud Vision API tasks to perform over --- images by using /Feature/s. Features encode the Cloud Vision API --- vertical to operate on and the number of top-scoring results to return. +-- | Users describe the type of Google Cloud Vision API tasks to perform over +-- images by using *Feature*s. Each Feature indicates a type of image +-- detection task to perform. Features encode the Cloud Vision API vertical +-- to operate on and the number of top-scoring results to return. -- -- /See:/ 'feature' smart constructor. data Feature = Feature' @@ -239,7 +241,7 @@ ("code" .=) <$> _sCode, ("message" .=) <$> _sMessage]) --- | Arbitrary name\/value pair. +-- | A \`Property\` consists of a user-supplied name\/value pair. -- -- /See:/ 'property' smart constructor. data Property = Property' @@ -286,7 +288,7 @@ -- -- /See:/ 'image' smart constructor. data Image = Image' - { _iContent :: !(Maybe Base64) + { _iContent :: !(Maybe Bytes) , _iSource :: !(Maybe ImageSource) } deriving (Eq,Show,Data,Typeable,Generic) @@ -311,11 +313,11 @@ iContent :: Lens' Image (Maybe ByteString) iContent = lens _iContent (\ s a -> s{_iContent = a}) . - mapping _Base64 + mapping _Bytes --- | Google Cloud Storage image location. If both \'content\' and \'source\' --- are filled for an image, \'content\' takes precedence and it will be --- used for performing the image annotation request. +-- | Google Cloud Storage image location. If both \`content\` and \`source\` +-- are provided for an image, \`content\` takes precedence and is used to +-- perform the image annotation request. iSource :: Lens' Image (Maybe ImageSource) iSource = lens _iSource (\ s a -> s{_iSource = a}) @@ -333,9 +335,9 @@ ("source" .=) <$> _iSource]) -- | A face-specific landmark (for example, a face feature). Landmark --- positions may fall outside the bounds of the image when the face is near --- one or more edges of the image. Therefore it is NOT guaranteed that 0 --- \<= x \< width or 0 \<= y \< height. +-- positions may fall outside the bounds of the image if the face is near +-- one or more edges of the image. Therefore it is NOT guaranteed that \`0 +-- \<= x \< width\` or \`0 \<= y \< height\`. -- -- /See:/ 'landmark' smart constructor. data Landmark = Landmark' @@ -600,7 +602,7 @@ { _liLatLng = Nothing } --- | Lat - long location coordinates. +-- | lat\/long location coordinates. liLatLng :: Lens' LocationInfo (Maybe LatLng) liLatLng = lens _liLatLng (\ s a -> s{_liLatLng = a}) @@ -685,8 +687,8 @@ = object (catMaybes [("requests" .=) <$> _bairRequests]) --- | Color information consists of RGB channels, score and fraction of image --- the color occupies in the image. +-- | Color information consists of RGB channels, score, and the fraction of +-- the image that the color occupies in the image. -- -- /See:/ 'colorInfo' smart constructor. data ColorInfo = ColorInfo' @@ -723,8 +725,8 @@ = lens _ciScore (\ s a -> s{_ciScore = a}) . mapping _Coerce --- | Stores the fraction of pixels the color occupies in the image. Value in --- range [0, 1]. +-- | The fraction of pixels the color occupies in the image. Value in range +-- [0, 1]. ciPixelFraction :: Lens' ColorInfo (Maybe Double) ciPixelFraction = lens _ciPixelFraction @@ -794,7 +796,7 @@ , _airImagePropertiesAnnotation = Nothing } --- | If present, logo detection completed successfully. +-- | If present, logo detection has completed successfully. airLogoAnnotations :: Lens' AnnotateImageResponse [EntityAnnotation] airLogoAnnotations = lens _airLogoAnnotations @@ -802,7 +804,7 @@ . _Default . _Coerce --- | If present, label detection completed successfully. +-- | If present, label detection has completed successfully. airLabelAnnotations :: Lens' AnnotateImageResponse [EntityAnnotation] airLabelAnnotations = lens _airLabelAnnotations @@ -810,7 +812,7 @@ . _Default . _Coerce --- | If present, face detection completed successfully. +-- | If present, face detection has completed successfully. airFaceAnnotations :: Lens' AnnotateImageResponse [FaceAnnotation] airFaceAnnotations = lens _airFaceAnnotations @@ -819,18 +821,18 @@ . _Coerce -- | If set, represents the error message for the operation. Note that --- filled-in mage annotations are guaranteed to be correct, even when --- 'error' is non-empty. +-- filled-in image annotations are guaranteed to be correct, even when +-- \`error\` is set. airError :: Lens' AnnotateImageResponse (Maybe Status) airError = lens _airError (\ s a -> s{_airError = a}) --- | If present, safe-search annotation completed successfully. +-- | If present, safe-search annotation has completed successfully. airSafeSearchAnnotation :: Lens' AnnotateImageResponse (Maybe SafeSearchAnnotation) airSafeSearchAnnotation = lens _airSafeSearchAnnotation (\ s a -> s{_airSafeSearchAnnotation = a}) --- | If present, landmark detection completed successfully. +-- | If present, landmark detection has completed successfully. airLandmarkAnnotations :: Lens' AnnotateImageResponse [EntityAnnotation] airLandmarkAnnotations = lens _airLandmarkAnnotations @@ -838,7 +840,7 @@ . _Default . _Coerce --- | If present, text (OCR) detection completed successfully. +-- | If present, text (OCR) detection has completed successfully. airTextAnnotations :: Lens' AnnotateImageResponse [EntityAnnotation] airTextAnnotations = lens _airTextAnnotations @@ -882,7 +884,7 @@ ("imagePropertiesAnnotation" .=) <$> _airImagePropertiesAnnotation]) --- | Stores image properties (e.g. dominant colors). +-- | Stores image properties, such as dominant colors. -- -- /See:/ 'imageProperties' smart constructor. newtype ImageProperties = ImageProperties' @@ -994,8 +996,8 @@ , _faLandmarks = Nothing } --- | Pitch angle. Indicates the upwards\/downwards angle that the face is --- pointing relative to the image\'s horizontal plane. Range [-180,180]. +-- | Pitch angle, which indicates the upwards\/downwards angle that the face +-- is pointing relative to the image\'s horizontal plane. Range [-180,180]. faTiltAngle :: Lens' FaceAnnotation (Maybe Double) faTiltAngle = lens _faTiltAngle (\ s a -> s{_faTiltAngle = a}) . @@ -1008,12 +1010,12 @@ (\ s a -> s{_faBlurredLikelihood = a}) -- | The bounding polygon around the face. The coordinates of the bounding --- box are in the original image\'s scale, as returned in ImageParams. The --- bounding box is computed to \"frame\" the face in accordance with human --- expectations. It is based on the landmarker results. Note that one or --- more x and\/or y coordinates may not be generated in the BoundingPoly --- (the polygon will be unbounded) if only a partial face appears in the --- image to be annotated. +-- box are in the original image\'s scale, as returned in \`ImageParams\`. +-- The bounding box is computed to \"frame\" the face in accordance with +-- human expectations. It is based on the landmarker results. Note that one +-- or more x and\/or y coordinates may not be generated in the +-- \`BoundingPoly\` (the polygon will be unbounded) if only a partial face +-- appears in the image to be annotated. faBoundingPoly :: Lens' FaceAnnotation (Maybe BoundingPoly) faBoundingPoly = lens _faBoundingPoly @@ -1032,17 +1034,17 @@ (\ s a -> s{_faLandmarkingConfidence = a}) . mapping _Coerce --- | Yaw angle. Indicates the leftward\/rightward angle that the face is --- pointing, relative to the vertical plane perpendicular to the image. +-- | Yaw angle, which indicates the leftward\/rightward angle that the face +-- is pointing relative to the vertical plane perpendicular to the image. -- Range [-180,180]. faPanAngle :: Lens' FaceAnnotation (Maybe Double) faPanAngle = lens _faPanAngle (\ s a -> s{_faPanAngle = a}) . mapping _Coerce --- | Roll angle. Indicates the amount of clockwise\/anti-clockwise rotation --- of the face relative to the image vertical, about the axis perpendicular --- to the face. Range [-180,180]. +-- | Roll angle, which indicates the amount of clockwise\/anti-clockwise +-- rotation of the face relative to the image vertical about the axis +-- perpendicular to the face. Range [-180,180]. faRollAngle :: Lens' FaceAnnotation (Maybe Double) faRollAngle = lens _faRollAngle (\ s a -> s{_faRollAngle = a}) . @@ -1054,12 +1056,12 @@ = lens _faUnderExposedLikelihood (\ s a -> s{_faUnderExposedLikelihood = a}) --- | This bounding polygon is tighter than the previous 'boundingPoly', and --- encloses only the skin part of the face. Typically, it is used to --- eliminate the face from any image analysis that detects the \"amount of --- skin\" visible in an image. It is not based on the landmarker results, --- only on the initial face detection, hence the 'fd' (face detection) --- prefix. +-- | The \`fd_bounding_poly\` bounding polygon is tighter than the +-- \`boundingPoly\`, and encloses only the skin part of the face. +-- Typically, it is used to eliminate the face from any image analysis that +-- detects the \"amount of skin\" visible in an image. It is not based on +-- the landmarker results, only on the initial face detection, hence the +-- 'fd' (face detection) prefix. faFdBoundingPoly :: Lens' FaceAnnotation (Maybe BoundingPoly) faFdBoundingPoly = lens _faFdBoundingPoly @@ -1204,21 +1206,21 @@ mapping _Coerce -- | The relevancy of the ICA (Image Content Annotation) label to the image. --- For example, the relevancy of \'tower\' to an image containing \'Eiffel --- Tower\' is likely higher than an image containing a distant towering --- building, though the confidence that there is a tower may be the same. --- Range [0, 1]. +-- For example, the relevancy of \"tower\" is likely higher to an image +-- containing the detected \"Eiffel Tower\" than to an image containing a +-- detected distant towering building, even though the confidence that +-- there is a tower in each image may be the same. Range [0, 1]. eaTopicality :: Lens' EntityAnnotation (Maybe Double) eaTopicality = lens _eaTopicality (\ s a -> s{_eaTopicality = a}) . mapping _Coerce -- | The language code for the locale in which the entity textual --- 'description' (next field) is expressed. +-- \`description\` is expressed. eaLocale :: Lens' EntityAnnotation (Maybe Text) eaLocale = lens _eaLocale (\ s a -> s{_eaLocale = a}) --- | Image region to which this entity belongs. Not filled currently for +-- | Image region to which this entity belongs. Currently not produced for -- \`LABEL_DETECTION\` features. For \`TEXT_DETECTION\` (OCR), -- \`boundingPoly\`s are produced for the entire text detected in an image -- region, followed by \`boundingPoly\`s for each word within the detected @@ -1229,38 +1231,38 @@ (\ s a -> s{_eaBoundingPoly = a}) -- | The accuracy of the entity detection in an image. For example, for an --- image containing \'Eiffel Tower,\' this field represents the confidence --- that there is a tower in the query image. Range [0, 1]. +-- image in which the \"Eiffel Tower\" entity is detected, this field +-- represents the confidence that there is a tower in the query image. +-- Range [0, 1]. eaConfidence :: Lens' EntityAnnotation (Maybe Double) eaConfidence = lens _eaConfidence (\ s a -> s{_eaConfidence = a}) . mapping _Coerce --- | Opaque entity ID. Some IDs might be available in Knowledge Graph(KG). --- For more details on KG please see: --- https:\/\/developers.google.com\/knowledge-graph\/ +-- | Opaque entity ID. Some IDs may be available in [Google Knowledge Graph +-- Search API](https:\/\/developers.google.com\/knowledge-graph\/). eaMid :: Lens' EntityAnnotation (Maybe Text) eaMid = lens _eaMid (\ s a -> s{_eaMid = a}) -- | The location information for the detected entity. Multiple --- 'LocationInfo' elements can be present since one location may indicate --- the location of the scene in the query image, and another the location --- of the place where the query image was taken. Location information is --- usually present for landmarks. +-- \`LocationInfo\` elements can be present because one location may +-- indicate the location of the scene in the image, and another location +-- may indicate the location of the place where the image was taken. +-- Location information is usually present for landmarks. eaLocations :: Lens' EntityAnnotation [LocationInfo] eaLocations = lens _eaLocations (\ s a -> s{_eaLocations = a}) . _Default . _Coerce --- | Entity textual description, expressed in its 'locale' language. +-- | Entity textual description, expressed in its \`locale\` language. eaDescription :: Lens' EntityAnnotation (Maybe Text) eaDescription = lens _eaDescription (\ s a -> s{_eaDescription = a}) --- | Some entities can have additional optional 'Property' fields. For --- example a different kind of score or string that qualifies the entity. +-- | Some entities may have optional user-supplied \`Property\` (name\/value) +-- fields, such a score or string that qualifies the entity. eaProperties :: Lens' EntityAnnotation [Property] eaProperties = lens _eaProperties (\ s a -> s{_eaProperties = a}) @@ -1375,10 +1377,11 @@ { _isGcsImageURI = Nothing } --- | Google Cloud Storage image URI. It must be in the following form: --- \`gs:\/\/bucket_name\/object_name\`. For more details, please see: --- https:\/\/cloud.google.com\/storage\/docs\/reference-uris. NOTE: Cloud --- Storage object versioning is not supported! +-- | Google Cloud Storage image URI, which must be in the following form: +-- \`gs:\/\/bucket_name\/object_name\` (for details, see [Google Cloud +-- Storage Request +-- URIs](https:\/\/cloud.google.com\/storage\/docs\/reference-uris)). NOTE: +-- Cloud Storage object versioning is not supported. isGcsImageURI :: Lens' ImageSource (Maybe Text) isGcsImageURI = lens _isGcsImageURI @@ -1394,9 +1397,6 @@ = object (catMaybes [("gcsImageUri" .=) <$> _isGcsImageURI]) --- | Set of features pertaining to the image, computed by various computer --- vision methods over safe-search verticals (for example, adult, spoof, --- medical, violence). -- -- /See:/ 'safeSearchAnnotation' smart constructor. data SafeSearchAnnotation = SafeSearchAnnotation' @@ -1427,16 +1427,16 @@ , _ssaViolence = Nothing } --- | Spoof likelihood. The likelihood that an obvious modification was made --- to the image\'s canonical version to make it appear funny or offensive. +-- | Spoof likelihood. The likelihood that an modification was made to the +-- image\'s canonical version to make it appear funny or offensive. ssaSpoof :: Lens' SafeSearchAnnotation (Maybe SafeSearchAnnotationSpoof) ssaSpoof = lens _ssaSpoof (\ s a -> s{_ssaSpoof = a}) --- | Represents the adult contents likelihood for the image. +-- | Represents the adult content likelihood for the image. ssaAdult :: Lens' SafeSearchAnnotation (Maybe SafeSearchAnnotationAdult) ssaAdult = lens _ssaAdult (\ s a -> s{_ssaAdult = a}) --- | Likelihood this is a medical image. +-- | Likelihood that this is a medical image. ssaMedical :: Lens' SafeSearchAnnotation (Maybe SafeSearchAnnotationMedical) ssaMedical = lens _ssaMedical (\ s a -> s{_ssaMedical = a}) @@ -1464,7 +1464,7 @@ ("medical" .=) <$> _ssaMedical, ("violence" .=) <$> _ssaViolence]) --- | Image context. +-- | Image context and\/or feature-specific parameters. -- -- /See:/ 'imageContext' smart constructor. data ImageContext = ImageContext' @@ -1495,7 +1495,7 @@ -- results (although it will be a significant hindrance if the hint is -- wrong). Text detection returns an error if one or more of the specified -- languages is not one of the [supported --- languages](\/translate\/v2\/translate-reference#supported_languages). +-- languages](\/vision\/docs\/languages). icLanguageHints :: Lens' ImageContext [Text] icLanguageHints = lens _icLanguageHints @@ -1503,7 +1503,7 @@ . _Default . _Coerce --- | Lat\/long rectangle that specifies the location of the image. +-- | lat\/long rectangle that specifies the location of the image. icLatLongRect :: Lens' ImageContext (Maybe LatLongRect) icLatLongRect = lens _icLatLongRect @@ -1543,7 +1543,7 @@ { _dcaColors = Nothing } --- | RGB color values, with their score and pixel fraction. +-- | RGB color values with their score and pixel fraction. dcaColors :: Lens' DominantColorsAnnotation [ColorInfo] dcaColors = lens _dcaColors (\ s a -> s{_dcaColors = a}) . @@ -1561,7 +1561,7 @@ toJSON DominantColorsAnnotation'{..} = object (catMaybes [("colors" .=) <$> _dcaColors]) --- | Rectangle determined by min and max LatLng pairs. +-- | Rectangle determined by min and max \`LatLng\` pairs. -- -- /See:/ 'latLongRect' smart constructor. data LatLongRect = LatLongRect' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-vision-0.1.1/gen/Network/Google/Vision/Types/Sum.hs new/gogol-vision-0.3.0/gen/Network/Google/Vision/Types/Sum.hs --- old/gogol-vision-0.1.1/gen/Network/Google/Vision/Types/Sum.hs 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-vision-0.3.0/gen/Network/Google/Vision/Types/Sum.hs 2017-07-12 16:45:05.000000000 +0200 @@ -25,19 +25,19 @@ -- Unknown likelihood. | VeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | Unlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | Possible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | Likely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | VeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FaceAnnotationUnderExposedLikelihood @@ -74,19 +74,19 @@ -- Unknown likelihood. | FAHLVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | FAHLUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | FAHLPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | FAHLLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | FAHLVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FaceAnnotationHeadwearLikelihood @@ -116,26 +116,26 @@ instance ToJSON FaceAnnotationHeadwearLikelihood where toJSON = toJSONText --- | Represents the adult contents likelihood for the image. +-- | Represents the adult content likelihood for the image. data SafeSearchAnnotationAdult = SSAAUnknown -- ^ @UNKNOWN@ -- Unknown likelihood. | SSAAVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | SSAAUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | SSAAPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | SSAALikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | SSAAVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable SafeSearchAnnotationAdult @@ -172,19 +172,19 @@ -- Unknown likelihood. | FAALVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | FAALUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | FAALPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | FAALLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | FAALVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FaceAnnotationAngerLikelihood @@ -214,26 +214,26 @@ instance ToJSON FaceAnnotationAngerLikelihood where toJSON = toJSONText --- | Likelihood this is a medical image. +-- | Likelihood that this is a medical image. data SafeSearchAnnotationMedical = SSAMUnknown -- ^ @UNKNOWN@ -- Unknown likelihood. | SSAMVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | SSAMUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | SSAMPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | SSAMLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | SSAMVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable SafeSearchAnnotationMedical @@ -270,19 +270,19 @@ -- Unknown likelihood. | FABLVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | FABLUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | FABLPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | FABLLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | FABLVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FaceAnnotationBlurredLikelihood @@ -319,19 +319,19 @@ -- Unknown likelihood. | SSAVVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | SSAVUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | SSAVPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | SSAVLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | SSAVVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable SafeSearchAnnotationViolence @@ -383,12 +383,10 @@ -- Run OCR. | SafeSearchDetection -- ^ @SAFE_SEARCH_DETECTION@ - -- Run various computer vision models to compute image safe-search - -- properties. + -- Run computer vision models to compute image safe-search properties. | ImageProperties -- ^ @IMAGE_PROPERTIES@ - -- Compute a set of properties about the image (such as the image\'s - -- dominant colors). + -- Compute a set of image properties, such as the image\'s dominant colors. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FeatureType @@ -645,27 +643,27 @@ instance ToJSON Xgafv where toJSON = toJSONText --- | Spoof likelihood. The likelihood that an obvious modification was made --- to the image\'s canonical version to make it appear funny or offensive. +-- | Spoof likelihood. The likelihood that an modification was made to the +-- image\'s canonical version to make it appear funny or offensive. data SafeSearchAnnotationSpoof = SSASUnknown -- ^ @UNKNOWN@ -- Unknown likelihood. | SSASVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | SSASUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | SSASPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | SSASLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | SSASVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable SafeSearchAnnotationSpoof @@ -702,19 +700,19 @@ -- Unknown likelihood. | FASLVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | FASLUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | FASLPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | FASLLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | FASLVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FaceAnnotationSurpriseLikelihood @@ -751,19 +749,19 @@ -- Unknown likelihood. | FVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | FUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | FPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | FLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | FVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FaceAnnotationSorrowLikelihood @@ -800,19 +798,19 @@ -- Unknown likelihood. | FAJLVeryUnlikely -- ^ @VERY_UNLIKELY@ - -- The image very unlikely belongs to the vertical specified. + -- It is very unlikely that the image belongs to the specified vertical. | FAJLUnlikely -- ^ @UNLIKELY@ - -- The image unlikely belongs to the vertical specified. + -- It is unlikely that the image belongs to the specified vertical. | FAJLPossible -- ^ @POSSIBLE@ - -- The image possibly belongs to the vertical specified. + -- It is possible that the image belongs to the specified vertical. | FAJLLikely -- ^ @LIKELY@ - -- The image likely belongs to the vertical specified. + -- It is likely that the image belongs to the specified vertical. | FAJLVeryLikely -- ^ @VERY_LIKELY@ - -- The image very likely belongs to the vertical specified. + -- It is very likely that the image belongs to the specified vertical. deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) instance Hashable FaceAnnotationJoyLikelihood diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-vision-0.1.1/gogol-vision.cabal new/gogol-vision-0.3.0/gogol-vision.cabal --- old/gogol-vision-0.1.1/gogol-vision.cabal 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-vision-0.3.0/gogol-vision.cabal 2017-07-12 16:45:05.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-vision -version: 0.1.1 +version: 0.3.0 synopsis: Google Cloud Vision SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -44,5 +44,5 @@ , Network.Google.Vision.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-useraccounts for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-useraccounts for openSUSE:Factory checked in at 2017-08-31 20:55:17 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-useraccounts (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-useraccounts.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-useraccounts" Thu Aug 31 20:55:17 2017 rev:2 rq:513352 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-useraccounts/ghc-gogol-useraccounts.changes 2017-05-10 20:44:28.446012918 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-useraccounts.new/ghc-gogol-useraccounts.changes 2017-08-31 20:55:21.684707328 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:59 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-useraccounts-0.1.1.tar.gz New: ---- gogol-useraccounts-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-useraccounts.spec ++++++ --- /var/tmp/diff_new_pack.87Jhg5/_old 2017-08-31 20:55:22.728560662 +0200 +++ /var/tmp/diff_new_pack.87Jhg5/_new 2017-08-31 20:55:22.740558976 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-useraccounts Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google Cloud User Accounts SDK License: MPL-2.0 ++++++ gogol-useraccounts-0.1.1.tar.gz -> gogol-useraccounts-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-useraccounts-0.1.1/README.md new/gogol-useraccounts-0.3.0/README.md --- old/gogol-useraccounts-0.1.1/README.md 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-useraccounts-0.3.0/README.md 2017-07-12 16:45:05.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-useraccounts-0.1.1/gogol-useraccounts.cabal new/gogol-useraccounts-0.3.0/gogol-useraccounts.cabal --- old/gogol-useraccounts-0.1.1/gogol-useraccounts.cabal 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-useraccounts-0.3.0/gogol-useraccounts.cabal 2017-07-12 16:45:05.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-useraccounts -version: 0.1.1 +version: 0.3.0 synopsis: Google Cloud User Accounts SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -59,5 +59,5 @@ , Network.Google.UserAccounts.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-urlshortener for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-urlshortener for openSUSE:Factory checked in at 2017-08-31 20:55:16 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-urlshortener (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-urlshortener.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-urlshortener" Thu Aug 31 20:55:16 2017 rev:2 rq:513351 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-urlshortener/ghc-gogol-urlshortener.changes 2017-05-10 20:44:25.990359414 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-urlshortener.new/ghc-gogol-urlshortener.changes 2017-08-31 20:55:17.221334447 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:11 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-urlshortener-0.1.1.tar.gz New: ---- gogol-urlshortener-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-urlshortener.spec ++++++ --- /var/tmp/diff_new_pack.Tlwo5F/_old 2017-08-31 20:55:18.461160247 +0200 +++ /var/tmp/diff_new_pack.Tlwo5F/_new 2017-08-31 20:55:18.473158561 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-urlshortener Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google URL Shortener SDK License: MPL-2.0 ++++++ gogol-urlshortener-0.1.1.tar.gz -> gogol-urlshortener-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-urlshortener-0.1.1/README.md new/gogol-urlshortener-0.3.0/README.md --- old/gogol-urlshortener-0.1.1/README.md 2016-11-03 14:26:27.000000000 +0100 +++ new/gogol-urlshortener-0.3.0/README.md 2017-07-12 16:45:06.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-urlshortener-0.1.1/gogol-urlshortener.cabal new/gogol-urlshortener-0.3.0/gogol-urlshortener.cabal --- old/gogol-urlshortener-0.1.1/gogol-urlshortener.cabal 2016-11-03 14:26:27.000000000 +0100 +++ new/gogol-urlshortener-0.3.0/gogol-urlshortener.cabal 2017-07-12 16:45:06.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-urlshortener -version: 0.1.1 +version: 0.3.0 synopsis: Google URL Shortener SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -44,5 +44,5 @@ , Network.Google.URLShortener.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-translate for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-translate for openSUSE:Factory checked in at 2017-08-31 20:55:10 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-translate (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-translate.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-translate" Thu Aug 31 20:55:10 2017 rev:2 rq:513350 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-translate/ghc-gogol-translate.changes 2017-05-10 20:44:24.286599816 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-translate.new/ghc-gogol-translate.changes 2017-08-31 20:55:14.609701391 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:06 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-translate-0.1.1.tar.gz New: ---- gogol-translate-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-translate.spec ++++++ --- /var/tmp/diff_new_pack.8y42YH/_old 2017-08-31 20:55:16.605420985 +0200 +++ /var/tmp/diff_new_pack.8y42YH/_new 2017-08-31 20:55:16.637416490 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-translate Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google Translate SDK License: MPL-2.0 ++++++ gogol-translate-0.1.1.tar.gz -> gogol-translate-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-translate-0.1.1/README.md new/gogol-translate-0.3.0/README.md --- old/gogol-translate-0.1.1/README.md 2016-11-03 14:26:27.000000000 +0100 +++ new/gogol-translate-0.3.0/README.md 2017-07-12 16:45:06.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-translate-0.1.1/gogol-translate.cabal new/gogol-translate-0.3.0/gogol-translate.cabal --- old/gogol-translate-0.1.1/gogol-translate.cabal 2016-11-03 14:26:27.000000000 +0100 +++ new/gogol-translate-0.3.0/gogol-translate.cabal 2017-07-12 16:45:06.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-translate -version: 0.1.1 +version: 0.3.0 synopsis: Google Translate SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -44,5 +44,5 @@ , Network.Google.Translate.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0

commit ghc-gogol-taskqueue for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-gogol-taskqueue for openSUSE:Factory checked in at 2017-08-31 20:55:07 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-gogol-taskqueue (Old) and /work/SRC/openSUSE:Factory/.ghc-gogol-taskqueue.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-gogol-taskqueue" Thu Aug 31 20:55:07 2017 rev:2 rq:513349 version:0.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-gogol-taskqueue/ghc-gogol-taskqueue.changes 2017-05-10 20:44:16.555690657 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-gogol-taskqueue.new/ghc-gogol-taskqueue.changes 2017-08-31 20:55:10.698250964 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:38 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0. + +------------------------------------------------------------------- Old: ---- gogol-taskqueue-0.1.1.tar.gz New: ---- gogol-taskqueue-0.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-gogol-taskqueue.spec ++++++ --- /var/tmp/diff_new_pack.dPVeMC/_old 2017-08-31 20:55:12.254032372 +0200 +++ /var/tmp/diff_new_pack.dPVeMC/_new 2017-08-31 20:55:12.298026190 +0200 @@ -18,7 +18,7 @@ %global pkg_name gogol-taskqueue Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.3.0 Release: 0 Summary: Google TaskQueue SDK License: MPL-2.0 ++++++ gogol-taskqueue-0.1.1.tar.gz -> gogol-taskqueue-0.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-taskqueue-0.1.1/README.md new/gogol-taskqueue-0.3.0/README.md --- old/gogol-taskqueue-0.1.1/README.md 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-taskqueue-0.3.0/README.md 2017-07-12 16:45:05.000000000 +0200 @@ -8,7 +8,7 @@ ## Version -`0.1.1` +`0.3.0` ## Description diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/gogol-taskqueue-0.1.1/gogol-taskqueue.cabal new/gogol-taskqueue-0.3.0/gogol-taskqueue.cabal --- old/gogol-taskqueue-0.1.1/gogol-taskqueue.cabal 2016-11-03 14:26:26.000000000 +0100 +++ new/gogol-taskqueue-0.3.0/gogol-taskqueue.cabal 2017-07-12 16:45:05.000000000 +0200 @@ -1,5 +1,5 @@ name: gogol-taskqueue -version: 0.1.1 +version: 0.3.0 synopsis: Google TaskQueue SDK. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -49,5 +49,5 @@ , Network.Google.TaskQueue.Types.Sum build-depends: - gogol-core == 0.1.1.* + gogol-core == 0.3.0.* , base >= 4.7 && < 5

1 0