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

(.using
 [library
  [lux (.except)
   [program (.only program:)]
   ["_" test (.only Test)]
   [abstract
    [monad (.only do)]]
   [control
    ["[0]" io]
    ["[0]" maybe (.open: "[1]#[0]" functor)]]
   [data
    ["[0]" bit (.open: "[1]#[0]" equivalence)]
    ["[0]" text]
    [collection
     ["[0]" list (.open: "[1]#[0]" functor)]]]
   [math
    ["[0]" random (.only Random)]
    [number
     ["n" nat (.open: "[1]#[0]" interval)]]]]]
 [\\program
  ["[0]" output]
  ["[0]" license (.only Identification
                        Termination
                        Liability
                        Distribution
                        Commercial
                        Extension
                        Entity Black_List
                        URL Attribution
                        Addendum
                        License)
   ["[0]" time (.only 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 (at ! each
             (|>> (n.% wiggle_room) (n.max 1))
             random.nat)]
    (wrap [time.#start start
           time.#end end])))

(def: copyright_holder
  (Random copyright.Holder)
  (all random.and
       (random.ascii 10)
       ..period))

(def: identification
  (Random Identification)
  (all random.and
       (random.ascii 10)
       (random.ascii 10)))

(def: termination
  (Random Termination)
  (all random.and
       random.bit
       random.nat
       random.nat))

(def: liability
  (Random Liability)
  (all random.and
       random.bit
       random.bit))

(def: distribution
  (Random Distribution)
  (all random.and
       random.bit
       random.bit))

(def: commercial
  (Random Commercial)
  (all random.and
       random.bit
       random.bit
       random.bit))

(def: extension
  (Random Extension)
  (all 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 (at ! each (n.% (n.max 1 max_size))
                random.nat)]
    (random.list amount gen_element)))

(def: black_list
  (Random Black_List)
  (all random.and
       (random.maybe (random.ascii 10))
       (variable_list 10 ..entity)))

(def: url
  (Random URL)
  (random.ascii 10))

(def: attribution
  (Random Attribution)
  (all random.and
       (random.ascii 10)
       (random.maybe (random.ascii 10))
       ..url
       (random.maybe ..url)))

(def: addendum
  (Random Addendum)
  (all random.and
       random.bit
       ))

(def: license
  (Random License)
  (all 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)
  (all _.and
       (_.property "Copyright grant is present."
         (present? grant.copyright))
       (_.property "Patent grant is present."
         (present? (grant.patent (the license.#patent_retaliation? termination))))
       (_.property "Effective date for the grants is present."
         (present? grant.date))
       (_.property "Patent grant is present."
         (present? (grant.termination (the license.#termination_period termination)
                                      (the license.#grace_period termination))))
       (_.property "The termination period is accurately conveyed."
         (present? (grant.grant_restoration_clause (the license.#termination_period termination))))
       (_.property "The grace period is accurately conveyed."
         (present? (grant.grace_period_clause (the license.#grace_period termination))))
       (_.property "The grants are not retro-actively terminated."
         (present? grant.no_retroactive_termination))
       ))

(def: (about_liability present? liability)
  (Concern Liability)
  (all _.and
       (_.property "Warranty liability disclaimer is present."
         (present? liability.warranty))
       (_.property "Limitation of liability is present."
         (present? liability.limitation))
       (_.property "Litigation conditions are present."
         (present? liability.litigation))
       (_.property "Liability acceptance conditions may be present."
         (bit#= (the license.#can_accept? liability)
                (present? liability.can_accept)))
       (_.property "Liability acceptance conditions may be present."
         (bit#= (the license.#disclaim_high_risk? liability)
                (present? liability.disclaim_high_risk)))
       ))

(def: (about_distribution present? distribution)
  (Concern Distribution)
  (all _.and
       (_.property "Conditions for source-code distribution are present."
         (present? distribution.source_code_form))
       (_.property "Conditions for object-code distribution are present."
         (present? distribution.object_form))
       (_.property "Conditions for extension distribution are present."
         (present? (distribution.extension distribution)))
       ))

(def: (about_commercial present? commercial)
  (Concern Commercial)
  (all _.and
       (_.property "Non-commercial clause is present."
         (bit#= (not (the license.#can_sell? commercial))
                (present? commercial.cannot_sell)))
       (_.property "Contributor credit condition is present."
         (bit#= (the license.#require_contributor_credit? commercial)
                (present? commercial.require_contributor_attribution)))
       (_.property "Anti-endorsement condition is present."
         (bit#= (not (the license.#allow_contributor_endorsement? commercial))
                (present? commercial.disallow_contributor_endorsement)))
       ))

(def: (about_extension present? extension)
  (Concern Extension)
  (all _.and
       (_.property "The license is viral."
         (bit#= (the license.#same_license? extension)
                (and (list.every? present? extension.sharing_requirement)
                     (list.every? present? extension.license_conflict_resolution))))
       (_.property "Extensions must be distinguishable from the original work."
         (bit#= (the license.#must_be_distinguishable? extension)
                (present? extension.distinctness_requirement)))
       (_.property "The community must be notified of new extensions."
         (case (the license.#notification_period extension)
           {.#Some period}
           (present? (extension.notification_requirement period))

           {.#None}
           true))
       (_.property "Must describe modifications."
         (bit#= (the license.#must_describe_modifications? extension)
                (present? extension.description_requirement)))
       ))

(def: (about_attribution present? attribution)
  (Concern Attribution)
  (all _.and
       (_.property "The attribution copyright notice is present."
         (present? (the license.#copyright_notice attribution)))
       (_.property "The attribution phrase is present."
         (|> attribution
             (the license.#phrase)
             (maybe#each present?)
             (maybe.default true)))
       (_.property "The attribution URL is present."
         (present? (the license.#url attribution)))
       (_.property "The attribution image is present."
         (|> attribution
             (the license.#image)
             (maybe#each present?)
             (maybe.default true)))
       ))

(def: (about_miscellaneous present?)
  (-> (-> Text Bit) Test)
  (all _.and
       (_.property "License constitutes the entire agreement."
         (present? miscellaneous.entire_agreement))
       (_.property "Disclaims relationship of parties."
         (present? miscellaneous.relationship_of_parties))
       (_.property "Explicitly allows independent development."
         (present? miscellaneous.independent_development))
       (_.property "Clarifies consent to breach does not waiver."
         (present? miscellaneous.not_waiver))
       (_.property "Provides severability."
         (present? miscellaneous.severability))
       (_.property "Covers export restrictions."
         (present? miscellaneous.export_restrictions))
       ))

(def: (about_addendum present? value)
  (Concern Addendum)
  (all _.and
       (_.property "Commons clause"
         (bit#= (the license.#commons_clause? value)
                (present? addendum.commons_clause)))
       ))

(def: test
  Test
  (do random.monad
    [license ..license
     #let [writ (output.license license)
           present? (is (-> Text Bit)
                        (function (_ snippet)
                          (text.contains? snippet writ)))]]
    (all _.and
         (_.property "Copyright notices are present."
           (list.every? (|>> notice.copyright_holder present?)
                        (the license.#copyright_holders license)))
         
         (_.property "Identification is present (if the license is identified)."
           (case (the license.#identification license)
             {.#Some identification}
             (and (present? (output.identification identification))
                  (present? miscellaneous.new_versions))

             {.#None}
             (not (present? miscellaneous.new_versions))))

         (_.property "Black-lists (if wanted by licensor) are explicitly enumerated and justified."
           (list.every? (function (_ black_list)
                          (let [black_list_is_justified? (case (the license.#justification black_list)
                                                           {.#Some justification}
                                                           (present? justification)

                                                           {.#None}
                                                           bit.yes)
                                every_entity_is_mentioned? (|> black_list
                                                               (the license.#entities)
                                                               (list#each black_list.entity)
                                                               (list.every? present?))]
                            (and black_list_is_justified?
                                 every_entity_is_mentioned?)))
                        (the license.#black_lists license)))
         
         (_.property "All definitions are present."
           (list.every? (|>> output.definition present?)
                        definition.all))

         (_.property "Acceptance of the license is demanded."
           (present? limitation.acceptance))
         
         (..about_grant present? (the license.#termination license))
         
         (_.property "All limitations are present."
           (present? output.limitation))
         
         (_.property "All assurances are present."
           (present? output.assurance))
         
         (_.property "The terms of submission are present."
           (present? submission.contribution))
         
         (..about_liability present? (the license.#liability license))

         (..about_distribution present? (the license.#distribution license))

         (..about_commercial present? (the license.#commercial license))

         (..about_extension present? (the license.#extension license))

         (case (the license.#attribution license)
           {.#Some attribution}
           (..about_attribution present? attribution)

           {.#None}
           (_.property "Attribution is missing."
             bit.yes))

         (..about_miscellaneous present?)

         (..about_addendum present? (the license.#addendum license))

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

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