From 519c0c0c71cdf7ce3dfc64b9781ab826760b3d94 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 14 Jun 2021 18:33:54 -0400
Subject: Extracted Licentia out of the standard library.

---
 licentia/source/test/licentia.lux | 368 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 368 insertions(+)
 create mode 100644 licentia/source/test/licentia.lux

(limited to 'licentia/source/test')

diff --git a/licentia/source/test/licentia.lux b/licentia/source/test/licentia.lux
new file mode 100644
index 000000000..bf0f4929e
--- /dev/null
+++ b/licentia/source/test/licentia.lux
@@ -0,0 +1,368 @@
+(.module:
+  [lux #*
+   [program (#+ program:)]
+   ["_" test (#+ Test)]
+   [abstract
+    [monad (#+ do)]]
+   [control
+    [io (#+ io)]]
+   [data
+    ["." bit ("#\." equivalence)]
+    ["." maybe ("#\." functor)]
+    ["." text]
+    [collection
+     ["." list ("#\." functor)]]]
+   [math
+    ["." random (#+ Random)]
+    [number
+     ["n" nat ("#\." interval)]]]]
+  {#program
+   [/
+    ["." license (#+ Identification
+                     Termination
+                     Liability
+                     Distribution
+                     Commercial
+                     Extension
+                     Entity Black_List
+                     URL Attribution
+                     Addendum
+                     License)
+     ["." time (#+ Period)]
+     ["." copyright]
+     ["." notice]
+     ["." definition]
+     ["." grant]
+     ["." limitation]
+     ["." submission]
+     ["." liability]
+     ["." distribution]
+     ["." commercial]
+     ["." extension]
+     ["." miscellaneous]
+     ["." black_list]
+     ["." addendum]]
+    ["." output]]})
+
+(def: period
+  (Random (Period Nat))
+  (do {! random.monad}
+    [start (random.filter (|>> (n.= n\top) not)
+                          random.nat)
+     #let [wiggle_room (n.- start n\top)]
+     end (\ ! map
+            (|>> (n.% wiggle_room) (n.max 1))
+            random.nat)]
+    (wrap {#time.start start
+           #time.end end})))
+
+(def: copyright_holder
+  (Random copyright.Holder)
+  ($_ random.and
+      (random.ascii 10)
+      ..period))
+
+(def: identification
+  (Random Identification)
+  ($_ random.and
+      (random.ascii 10)
+      (random.ascii 10)))
+
+(def: termination
+  (Random Termination)
+  ($_ random.and
+      random.bit
+      random.nat
+      random.nat))
+
+(def: liability
+  (Random Liability)
+  ($_ random.and
+      random.bit
+      random.bit))
+
+(def: distribution
+  (Random Distribution)
+  ($_ random.and
+      random.bit
+      random.bit))
+
+(def: commercial
+  (Random Commercial)
+  ($_ random.and
+      random.bit
+      random.bit
+      random.bit))
+
+(def: extension
+  (Random Extension)
+  ($_ random.and
+      random.bit
+      random.bit
+      (random.maybe ..period)
+      random.bit))
+
+(def: entity
+  (Random Entity)
+  (random.ascii 10))
+
+(def: (variable_list max_size gen_element)
+  (All [a] (-> Nat (Random a) (Random (List a))))
+  (do {! random.monad}
+    [amount (\ ! map (n.% (n.max 1 max_size))
+               random.nat)]
+    (random.list amount gen_element)))
+
+(def: black_list
+  (Random Black_List)
+  ($_ random.and
+      (random.maybe (random.ascii 10))
+      (variable_list 10 ..entity)))
+
+(def: url
+  (Random URL)
+  (random.ascii 10))
+
+(def: attribution
+  (Random Attribution)
+  ($_ random.and
+      (random.ascii 10)
+      (random.maybe (random.ascii 10))
+      ..url
+      (random.maybe ..url)))
+
+(def: addendum
+  (Random Addendum)
+  ($_ random.and
+      random.bit
+      ))
+
+(def: license
+  (Random License)
+  ($_ random.and
+      (random.list 2 ..copyright_holder)
+      (random.maybe ..identification)
+      ..termination
+      ..liability
+      ..distribution
+      ..commercial
+      ..extension
+      (variable_list 3 ..black_list)
+      (random.maybe attribution)
+      ..addendum
+      ))
+
+(type: (Concern a)
+  (-> (-> Text Bit) a Test))
+
+(def: (about_grant present? termination)
+  (Concern Termination)
+  ($_ _.and
+      (_.test "Copyright grant is present."
+              (present? grant.copyright))
+      (_.test "Patent grant is present."
+              (present? (grant.patent (get@ #license.patent_retaliation? termination))))
+      (_.test "Effective date for the grants is present."
+              (present? grant.date))
+      (_.test "Patent grant is present."
+              (present? (grant.termination (get@ #license.termination_period termination)
+                                           (get@ #license.grace_period termination))))
+      (_.test "The termination period is accurately conveyed."
+              (present? (grant.grant_restoration_clause (get@ #license.termination_period termination))))
+      (_.test "The grace period is accurately conveyed."
+              (present? (grant.grace_period_clause (get@ #license.grace_period termination))))
+      (_.test "The grants are not retro-actively terminated."
+              (present? grant.no_retroactive_termination))
+      ))
+
+(def: (about_liability present? liability)
+  (Concern Liability)
+  ($_ _.and
+      (_.test "Warranty liability disclaimer is present."
+              (present? liability.warranty))
+      (_.test "Limitation of liability is present."
+              (present? liability.limitation))
+      (_.test "Litigation conditions are present."
+              (present? liability.litigation))
+      (_.test "Liability acceptance conditions may be present."
+              (bit\= (get@ #license.can_accept? liability)
+                     (present? liability.can_accept)))
+      (_.test "Liability acceptance conditions may be present."
+              (bit\= (get@ #license.disclaim_high_risk? liability)
+                     (present? liability.disclaim_high_risk)))
+      ))
+
+(def: (about_distribution present? distribution)
+  (Concern Distribution)
+  ($_ _.and
+      (_.test "Conditions for source-code distribution are present."
+              (present? distribution.source_code_form))
+      (_.test "Conditions for object-code distribution are present."
+              (present? distribution.object_form))
+      (_.test "Conditions for extension distribution are present."
+              (present? (distribution.extension distribution)))
+      ))
+
+(def: (about_commercial present? commercial)
+  (Concern Commercial)
+  ($_ _.and
+      (_.test "Non-commercial clause is present."
+              (bit\= (not (get@ #license.can_sell? commercial))
+                     (present? commercial.cannot_sell)))
+      (_.test "Contributor credit condition is present."
+              (bit\= (get@ #license.require_contributor_credit? commercial)
+                     (present? commercial.require_contributor_attribution)))
+      (_.test "Anti-endorsement condition is present."
+              (bit\= (not (get@ #license.allow_contributor_endorsement? commercial))
+                     (present? commercial.disallow_contributor_endorsement)))
+      ))
+
+(def: (about_extension present? extension)
+  (Concern Extension)
+  ($_ _.and
+      (_.test "The license is viral."
+              (bit\= (get@ #license.same_license? extension)
+                     (and (list.every? present? extension.sharing_requirement)
+                          (list.every? present? extension.license_conflict_resolution))))
+      (_.test "Extensions must be distinguishable from the original work."
+              (bit\= (get@ #license.must_be_distinguishable? extension)
+                     (present? extension.distinctness_requirement)))
+      (_.test "The community must be notified of new extensions."
+              (case (get@ #license.notification_period extension)
+                (#.Some period)
+                (present? (extension.notification_requirement period))
+
+                #.None
+                true))
+      (_.test "Must describe modifications."
+              (bit\= (get@ #license.must_describe_modifications? extension)
+                     (present? extension.description_requirement)))
+      ))
+
+(def: (about_attribution present? attribution)
+  (Concern Attribution)
+  ($_ _.and
+      (_.test "The attribution copyright notice is present."
+              (present? (get@ #license.copyright_notice attribution)))
+      (_.test "The attribution phrase is present."
+              (|> attribution
+                  (get@ #license.phrase)
+                  (maybe\map present?)
+                  (maybe.default true)))
+      (_.test "The attribution URL is present."
+              (present? (get@ #license.url attribution)))
+      (_.test "The attribution image is present."
+              (|> attribution
+                  (get@ #license.image)
+                  (maybe\map present?)
+                  (maybe.default true)))
+      ))
+
+(def: (about_miscellaneous present?)
+  (-> (-> Text Bit) Test)
+  ($_ _.and
+      (_.test "License constitutes the entire agreement."
+              (present? miscellaneous.entire_agreement))
+      (_.test "Disclaims relationship of parties."
+              (present? miscellaneous.relationship_of_parties))
+      (_.test "Explicitly allows independent development."
+              (present? miscellaneous.independent_development))
+      (_.test "Clarifies consent to breach does not waiver."
+              (present? miscellaneous.not_waiver))
+      (_.test "Provides severability."
+              (present? miscellaneous.severability))
+      (_.test "Covers export restrictions."
+              (present? miscellaneous.export_restrictions))
+      ))
+
+(def: (about_addendum present? value)
+  (Concern Addendum)
+  ($_ _.and
+      (_.test "Commons clause"
+              (bit\= (get@ #license.commons_clause? value)
+                     (present? addendum.commons_clause)))
+      ))
+
+(def: test
+  Test
+  (do random.monad
+    [license ..license
+     #let [writ (output.license license)
+           present? (: (-> Text Bit)
+                       (function (_ snippet)
+                         (text.contains? snippet writ)))]]
+    ($_ _.and
+        (_.test "Copyright notices are present."
+                (list.every? (|>> notice.copyright_holder present?)
+                             (get@ #license.copyright_holders license)))
+        
+        (_.test "Identification is present (if the license is identified)."
+                (case (get@ #license.identification license)
+                  (#.Some identification)
+                  (and (present? (output.identification identification))
+                       (present? miscellaneous.new_versions))
+
+                  #.None
+                  (not (present? miscellaneous.new_versions))))
+
+        (_.test "Black-lists (if wanted by licensor) are explicitly enumerated and justified."
+                (list.every? (function (_ black_list)
+                               (let [black_list_is_justified? (case (get@ #license.justification black_list)
+                                                                (#.Some justification)
+                                                                (present? justification)
+
+                                                                #.None
+                                                                yes)
+                                     every_entity_is_mentioned? (|> black_list
+                                                                    (get@ #license.entities)
+                                                                    (list\map black_list.entity)
+                                                                    (list.every? present?))]
+                                 (and black_list_is_justified?
+                                      every_entity_is_mentioned?)))
+                             (get@ #license.black_lists license)))
+        
+        (_.test "All definitions are present."
+                (list.every? (|>> output.definition present?)
+                             definition.all))
+
+        (_.test "Acceptance of the license is demanded."
+                (present? limitation.acceptance))
+        
+        (..about_grant present? (get@ #license.termination license))
+        
+        (_.test "All limitations are present."
+                (present? output.limitation))
+        
+        (_.test "All assurances are present."
+                (present? output.assurance))
+        
+        (_.test "The terms of submission are present."
+                (present? submission.contribution))
+        
+        (..about_liability present? (get@ #license.liability license))
+
+        (..about_distribution present? (get@ #license.distribution license))
+
+        (..about_commercial present? (get@ #license.commercial license))
+
+        (..about_extension present? (get@ #license.extension license))
+
+        (case (get@ #license.attribution license)
+          (#.Some attribution)
+          (..about_attribution present? attribution)
+
+          #.None
+          (_.test "Attribution is missing."
+                  yes))
+
+        (..about_miscellaneous present?)
+
+        (..about_addendum present? (get@ #license.addendum license))
+
+        (_.test "License ending footer is present."
+                (present? notice.end_of_license))
+        )))
+
+(program: args
+  (io (_.run! (<| (_.times 100)
+                  ..test))))
-- 
cgit v1.2.3