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

(.using
  [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))