path: root/licentia/source/test/licentia.lux

(.module:
  [library
   [lux "*"
    [program {"+" [program:]}]
    ["_" test {"+" [Test]}]
    [abstract
     [monad {"+" [do]}]]
    [control
     ["[0]" io]
     ["[0]" maybe ("[1]\[0]" functor)]]
    [data
     ["[0]" bit ("[1]\[0]" equivalence)]
     ["[0]" text]
     [collection
      ["[0]" list ("[1]\[0]" functor)]]]
    [math
     ["[0]" random {"+" [Random]}]
     [number
      ["n" nat ("[1]\[0]" interval)]]]]]
  [\\program
   ["[0]" output]
   ["[0]" license {"+" [Identification
                        Termination
                        Liability
                        Distribution
                        Commercial
                        Extension
                        Entity Black_List
                        URL Attribution
                        Addendum
                        License]}
    ["[0]" time {"+" [Period]}]
    ["[0]" copyright]
    ["[0]" notice]
    ["[0]" definition]
    ["[0]" grant]
    ["[0]" limitation]
    ["[0]" submission]
    ["[0]" liability]
    ["[0]" distribution]
    ["[0]" commercial]
    ["[0]" extension]
    ["[0]" miscellaneous]
    ["[0]" black_list]
    ["[0]" addendum]]])

(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 (\ ! each
            (|>> (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 (\ ! each (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 (value@ #license.patent_retaliation? termination))))
      (_.test "Effective date for the grants is present."
              (present? grant.date))
      (_.test "Patent grant is present."
              (present? (grant.termination (value@ #license.termination_period termination)
                                           (value@ #license.grace_period termination))))
      (_.test "The termination period is accurately conveyed."
              (present? (grant.grant_restoration_clause (value@ #license.termination_period termination))))
      (_.test "The grace period is accurately conveyed."
              (present? (grant.grace_period_clause (value@ #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\= (value@ #license.can_accept? liability)
                     (present? liability.can_accept)))
      (_.test "Liability acceptance conditions may be present."
              (bit\= (value@ #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 (value@ #license.can_sell? commercial))
                     (present? commercial.cannot_sell)))
      (_.test "Contributor credit condition is present."
              (bit\= (value@ #license.require_contributor_credit? commercial)
                     (present? commercial.require_contributor_attribution)))
      (_.test "Anti-endorsement condition is present."
              (bit\= (not (value@ #license.allow_contributor_endorsement? commercial))
                     (present? commercial.disallow_contributor_endorsement)))
      ))

(def: (about_extension present? extension)
  (Concern Extension)
  ($_ _.and
      (_.test "The license is viral."
              (bit\= (value@ #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\= (value@ #license.must_be_distinguishable? extension)
                     (present? extension.distinctness_requirement)))
      (_.test "The community must be notified of new extensions."
              (case (value@ #license.notification_period extension)
                (#.Some period)
                (present? (extension.notification_requirement period))

                #.None
                true))
      (_.test "Must describe modifications."
              (bit\= (value@ #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? (value@ #license.copyright_notice attribution)))
      (_.test "The attribution phrase is present."
              (|> attribution
                  (value@ #license.phrase)
                  (maybe\each present?)
                  (maybe.default true)))
      (_.test "The attribution URL is present."
              (present? (value@ #license.url attribution)))
      (_.test "The attribution image is present."
              (|> attribution
                  (value@ #license.image)
                  (maybe\each 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\= (value@ #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?)
                             (value@ #license.copyright_holders license)))
        
        (_.test "Identification is present (if the license is identified)."
                (case (value@ #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 (value@ #license.justification black_list)
                                                                (#.Some justification)
                                                                (present? justification)

                                                                #.None
                                                                bit.yes)
                                     every_entity_is_mentioned? (|> black_list
                                                                    (value@ #license.entities)
                                                                    (list\each black_list.entity)
                                                                    (list.every? present?))]
                                 (and black_list_is_justified?
                                      every_entity_is_mentioned?)))
                             (value@ #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? (value@ #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? (value@ #license.liability license))

        (..about_distribution present? (value@ #license.distribution license))

        (..about_commercial present? (value@ #license.commercial license))

        (..about_extension present? (value@ #license.extension license))

        (case (value@ #license.attribution license)
          (#.Some attribution)
          (..about_attribution present? attribution)

          #.None
          (_.test "Attribution is missing."
                  bit.yes))

        (..about_miscellaneous present?)

        (..about_addendum present? (value@ #license.addendum license))

        (_.test "License ending footer is present."
                (present? notice.end_of_license))
        )))

(program: args
  (<| io.io
      _.run!
      (_.times 100)
      ..test))