{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Modelling.CdOd.CdAndChanges.Transform (
  transform,
  transformChanges,
  transformGetNextFix,
  transformImproveCd,
  transformNoChanges,
  ) where

import Modelling.CdOd.Types (
  AllowedProperties (..),
  AnyCd,
  AnyClassDiagram (..),
  AnyRelationship,
  CdConstraints (..),
  CdMutation (..),
  ClassConfig (..),
  InvalidRelationship (..),
  LimitedLinking (..),
  Relationship (..),
  RelationshipMutation (..),
  RelationshipProperties (..),
  anyRelationshipName,
  defaultCdConstraints,
  maxRelationships,
  towardsValidProperties,
  )

import Data.Bool                        (bool)
import Data.FileEmbed                   (embedStringFile)
import Data.Functor                     ((<&>))
import Data.List                        (intercalate, unzip5)
import Data.List.Extra                  (nubOrd)
import Data.Maybe                       (fromMaybe)
import Data.String.Interpolate          (__i, __i'E, i, iii)

transformWith
  :: ClassConfig
  -> CdConstraints
  -> [CdMutation]
  -> Either AnyCd RelationshipProperties
  -> (Int, [String], String)
  -> String
transformWith :: ClassConfig
-> CdConstraints
-> [CdMutation]
-> Either AnyCd RelationshipProperties
-> (Int, [String], String)
-> String
transformWith ClassConfig
config CdConstraints
constraints [CdMutation]
mutations Either AnyCd RelationshipProperties
cdOrProperties (Int
cs, [String]
predicates, String
part) =
  String -> String
removeLine $(embedStringFile "alloy/cd/relationshipLimits.als")
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
removeLines Int
13 $(embedStringFile "alloy/cd/generate.als")
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [CdMutation] -> String
changePredicate [CdMutation]
mutations
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (AnyCd -> String)
-> (RelationshipProperties -> String)
-> Either AnyCd RelationshipProperties
-> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AnyCd -> String
givenClassDiagram (ClassConfig -> CdConstraints -> RelationshipProperties -> String
classDiagram ClassConfig
config CdConstraints
constraints) Either AnyCd RelationshipProperties
cdOrProperties
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
part
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ ClassConfig -> [String] -> Int -> String
createRunCommand ClassConfig
config [String]
predicates Int
cs

nameErrorPredicates :: String
nameErrorPredicates :: String
nameErrorPredicates =  Int -> String -> String
removeLines Int
3 $(embedStringFile "alloy/cd/nameError.als")
{-|
Create Alloy code for the generation of a single class diagram with the
given properties.
-}
transformNoChanges
  :: ClassConfig
  -> RelationshipProperties
  -> Maybe Bool
  -> String
transformNoChanges :: ClassConfig -> RelationshipProperties -> Maybe Bool -> String
transformNoChanges ClassConfig
config RelationshipProperties
properties Maybe Bool
withNonTrivialInheritance =
  ClassConfig
-> CdConstraints
-> [CdMutation]
-> Either AnyCd RelationshipProperties
-> (Int, [String], String)
-> String
transformWith ClassConfig
config CdConstraints
defaultCdConstraints [] (RelationshipProperties -> Either AnyCd RelationshipProperties
forall a b. b -> Either a b
Right RelationshipProperties
properties) (Int
0, [], String
part)
  where
    part :: String
part = [__i|
      fact{
      #{nonTrivialInheritanceConstraint "Inheritance" "NonInheritance" withNonTrivialInheritance}
      }
      |]

nonTrivialInheritanceConstraint :: String -> String -> Maybe Bool -> String
nonTrivialInheritanceConstraint :: String -> String -> Maybe Bool -> String
nonTrivialInheritanceConstraint String
inheritances String
nonInheritances Maybe Bool
withNonTrivialInheritance =
  ((String -> String) -> Maybe String -> String
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
`foldMap` Maybe String
trivialInheritance) ((String -> String) -> String) -> (String -> String) -> String
forall a b. (a -> b) -> a -> b
$ \String
x -> [i|  #{withInheritance}
  #{x} i : #{inheritances} | i.to in ((#{nonInheritances} + #{inheritances}).from + #{nonInheritances}.to)|]
  where
    trivialInheritance :: Maybe String
trivialInheritance = Maybe Bool
withNonTrivialInheritance
      Maybe Bool -> (Bool -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> String -> Bool -> String
forall a. a -> a -> Bool -> a
bool String
"no" String
"all"
    withInheritance :: String
withInheritance = String -> (Bool -> String) -> Maybe Bool -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      String
""
      (String -> String -> Bool -> String
forall a. a -> a -> Bool -> a
bool String
"" String
someInheritance)
      Maybe Bool
withNonTrivialInheritance
    someInheritance :: String
someInheritance = [i|some Inheritance <: #{inheritances}|]

transform
  :: ClassConfig
  -> [CdMutation]
  -> RelationshipProperties
  -> Maybe Bool
  -> String
transform :: ClassConfig
-> [CdMutation] -> RelationshipProperties -> Maybe Bool -> String
transform ClassConfig
config [CdMutation]
mutations RelationshipProperties
props Maybe Bool
withNonTrivialInheritance =
  ClassConfig
-> CdConstraints
-> [CdMutation]
-> Either AnyCd RelationshipProperties
-> (Int, [String], String)
-> String
transformWith ClassConfig
config CdConstraints
defaultCdConstraints [CdMutation]
mutations (RelationshipProperties -> Either AnyCd RelationshipProperties
forall a b. b -> Either a b
Right RelationshipProperties
props)
  ((Int, [String], String) -> String)
-> (Int, [String], String) -> String
forall a b. (a -> b) -> a -> b
$ ClassConfig -> Maybe Bool -> (Int, [String], String)
matchCdOdChanges ClassConfig
config Maybe Bool
withNonTrivialInheritance

transformChanges
  :: ClassConfig
  -> CdConstraints
  -> [CdMutation]
  -> RelationshipProperties
  -> Maybe ClassConfig
  -> [RelationshipProperties]
  -> String
transformChanges :: ClassConfig
-> CdConstraints
-> [CdMutation]
-> RelationshipProperties
-> Maybe ClassConfig
-> [RelationshipProperties]
-> String
transformChanges ClassConfig
config CdConstraints
constraints [CdMutation]
mutations RelationshipProperties
props Maybe ClassConfig
maybeConfig [RelationshipProperties]
propsList =
  ClassConfig
-> CdConstraints
-> [CdMutation]
-> Either AnyCd RelationshipProperties
-> (Int, [String], String)
-> String
transformWith ClassConfig
config CdConstraints
constraints [CdMutation]
mutations (RelationshipProperties -> Either AnyCd RelationshipProperties
forall a b. b -> Either a b
Right RelationshipProperties
props)
  ((Int, [String], String) -> String)
-> (Int, [String], String) -> String
forall a b. (a -> b) -> a -> b
$ Maybe ClassConfig
-> CdConstraints
-> [RelationshipProperties]
-> (Int, [String], String)
changes Maybe ClassConfig
maybeConfig CdConstraints
constraints [RelationshipProperties]
propsList

transformImproveCd
  :: AnyCd
  -- ^ the generated CD
  -> ClassConfig
  -- ^ the configuration used for generating the CD
  -> [CdMutation]
  -- ^ the mutations that are allowed to be used
  -> RelationshipProperties
  -- ^ the properties of the original CD
  -> String
transformImproveCd :: AnyCd
-> ClassConfig -> [CdMutation] -> RelationshipProperties -> String
transformImproveCd AnyCd
cd ClassConfig
config [CdMutation]
mutations RelationshipProperties
properties
  = ClassConfig
-> CdConstraints
-> [CdMutation]
-> Either AnyCd RelationshipProperties
-> (Int, [String], String)
-> String
transformWith ClassConfig
config CdConstraints
constraints [CdMutation]
mutations (AnyCd -> Either AnyCd RelationshipProperties
forall a b. a -> Either a b
Left AnyCd
cd)
  ((Int, [String], String) -> String)
-> (Int, [String], String) -> String
forall a b. (a -> b) -> a -> b
$ Maybe ClassConfig
-> CdConstraints
-> [RelationshipProperties]
-> (Int, [String], String)
changes Maybe ClassConfig
forall a. Maybe a
Nothing CdConstraints
constraints [RelationshipProperties -> RelationshipProperties
towardsValidProperties RelationshipProperties
properties]
  where
    constraints :: CdConstraints
constraints = CdConstraints
defaultCdConstraints

{-|
Generates Alloy code that

 * provides a change that removes an illegal relationship
 * makes sure, that no non-inheritance relationship exists twice within the
   class diagram if they are not referenced by name
-}
transformGetNextFix
  :: Maybe AnyCd
  -> ClassConfig
  -> CdConstraints
  -> RelationshipProperties
  -> AllowedProperties
  -> Bool
  -> String
transformGetNextFix :: Maybe AnyCd
-> ClassConfig
-> CdConstraints
-> RelationshipProperties
-> AllowedProperties
-> Bool
-> String
transformGetNextFix Maybe AnyCd
maybeCd ClassConfig
config CdConstraints
constraints RelationshipProperties
properties AllowedProperties
allowed Bool
byName
  = ClassConfig
-> CdConstraints
-> [CdMutation]
-> Either AnyCd RelationshipProperties
-> (Int, [String], String)
-> String
transformWith
  ClassConfig
config
  CdConstraints
constraints
  [CdMutation
RemoveRelationship]
  (Either AnyCd RelationshipProperties
-> (AnyCd -> Either AnyCd RelationshipProperties)
-> Maybe AnyCd
-> Either AnyCd RelationshipProperties
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RelationshipProperties -> Either AnyCd RelationshipProperties
forall a b. b -> Either a b
Right RelationshipProperties
properties) AnyCd -> Either AnyCd RelationshipProperties
forall a b. a -> Either a b
Left Maybe AnyCd
maybeCd)
  (Int
n, [String]
ps, String
part String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
restrictOverlappings String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
restrictRelationships)
  where
    (Int
n, [String]
ps, String
part) = Maybe ClassConfig
-> CdConstraints
-> [RelationshipProperties]
-> (Int, [String], String)
changes
      Maybe ClassConfig
forall a. Maybe a
Nothing
      CdConstraints
constraints
      [RelationshipProperties -> RelationshipProperties
towardsValidProperties RelationshipProperties
properties]
    overlappingFacts :: String
overlappingFacts = AllowedProperties -> String
restrictOverlapping AllowedProperties
allowed
    restrictOverlappings :: String
restrictOverlappings =
      if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
overlappingFacts
      then String
""
      else String
overlappingFacts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameErrorPredicates
    restrictOverlapping :: AllowedProperties -> String
restrictOverlapping AllowedProperties {Bool
compositionCycles :: Bool
doubleRelationships :: Bool
inheritanceCycles :: Bool
invalidInheritanceLimits :: Bool
reverseInheritances :: Bool
reverseRelationships :: Bool
selfInheritances :: Bool
selfRelationships :: Bool
wrongAssociationLimits :: Bool
wrongCompositionLimits :: Bool
compositionCycles :: AllowedProperties -> Bool
doubleRelationships :: AllowedProperties -> Bool
inheritanceCycles :: AllowedProperties -> Bool
invalidInheritanceLimits :: AllowedProperties -> Bool
reverseInheritances :: AllowedProperties -> Bool
reverseRelationships :: AllowedProperties -> Bool
selfInheritances :: AllowedProperties -> Bool
selfRelationships :: AllowedProperties -> Bool
wrongAssociationLimits :: AllowedProperties -> Bool
wrongCompositionLimits :: AllowedProperties -> Bool
..}
      = Bool -> String -> String -> String
addFact (Bool
compositionCycles Bool -> Bool -> Bool
&& Bool
selfRelationships) [__i'E|
        fact restrictSelfCompositionCycles {
          noSelfCycle  [Inheritance, Composition]
        }|]
      (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Bool -> String -> String -> String
addFact (Bool
compositionCycles Bool -> Bool -> Bool
&& Bool
reverseRelationships) [__i'E|
        fact restrictReverseCompositions {
          noInheritedReverseRelationships [Inheritance, Composition]
        }|]
      String
""
    addFact :: Bool -> String -> String -> String
addFact Bool
x String
fact String
facts = (if Bool
x then String
fact else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
facts
    restrictRelationships :: String
restrictRelationships =
      if Bool
byName
      then String
""
      else [i|
fact preventEqualNonInheritances {
  no disj x, y : NonInheritance |
    equalRelationship[x, y]
}
|]

nameRelationships
  :: AnyClassDiagram className String
  -> [(String, AnyRelationship className String)]
nameRelationships :: forall className.
AnyClassDiagram className String
-> [(String, AnyRelationship className String)]
nameRelationships AnyClassDiagram {[AnyRelationship className String]
anyRelationships :: [AnyRelationship className String]
anyRelationships :: forall className relationshipName.
AnyClassDiagram className relationshipName
-> [AnyRelationship className relationshipName]
anyRelationships} = (String
 -> AnyRelationship className String
 -> (String, AnyRelationship className String))
-> [String]
-> [AnyRelationship className String]
-> [(String, AnyRelationship className String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
  String
-> AnyRelationship className String
-> (String, AnyRelationship className String)
forall {a} {className}.
a
-> AnyRelationship className a -> (a, AnyRelationship className a)
addName
  ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"Relationship" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
0 :: Int ..])
  [AnyRelationship className String]
anyRelationships
  where
    addName :: a
-> AnyRelationship className a -> (a, AnyRelationship className a)
addName a
defaultName AnyRelationship className a
r = (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
defaultName (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ AnyRelationship className a -> Maybe a
forall className relationshipName.
AnyRelationship className relationshipName
-> Maybe relationshipName
anyRelationshipName AnyRelationship className a
r, AnyRelationship className a
r)

givenClassDiagram :: AnyCd -> String
givenClassDiagram :: AnyCd -> String
givenClassDiagram cd :: AnyCd
cd@AnyClassDiagram {[String]
anyClassNames :: [String]
anyClassNames :: forall className relationshipName.
AnyClassDiagram className relationshipName -> [className]
anyClassNames} = [i|
//////////////////////////////////////////////////
// Given CD
//////////////////////////////////////////////////

#{concatMap classSig anyClassNames}
#{concatMap relationshipSig namedRelationships}
pred cd {
  Class = #{unionOf anyClassNames}
#{concatMap relationshipConstraints namedRelationships}
  NonInheritance = Association + Aggregation + Composition
  Relationship = NonInheritance + Inheritance
  Association - Change.add = #{unionOf $ concat associations}
  Aggregation - Change.add = #{unionOf $ concat aggregations}
  Composition - Change.add = #{unionOf $ concat compositions}
  ValidInheritance - Change.add = #{unionOf $ concat validInheritances}
  InvalidInheritance - Change.add = #{unionOf $ concat invalidInheritances}
}
|]
  where
    unionOf :: [String] -> String
unionOf [String]
xs
      | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
xs = String
"none"
      | Bool
otherwise = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" + " [String]
xs
    namedRelationships :: [(String, AnyRelationship String String)]
namedRelationships = AnyCd -> [(String, AnyRelationship String String)]
forall className.
AnyClassDiagram className String
-> [(String, AnyRelationship className String)]
nameRelationships AnyCd
cd
    ([[String]]
invalidInheritances, [[String]]
associations, [[String]]
aggregations, [[String]]
compositions, [[String]]
validInheritances) =
      [([String], [String], [String], [String], [String])]
-> ([[String]], [[String]], [[String]], [[String]], [[String]])
forall a b c d e. [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])
unzip5 ([([String], [String], [String], [String], [String])]
 -> ([[String]], [[String]], [[String]], [[String]], [[String]]))
-> [([String], [String], [String], [String], [String])]
-> ([[String]], [[String]], [[String]], [[String]], [[String]])
forall a b. (a -> b) -> a -> b
$ ((String, AnyRelationship String String)
 -> ([String], [String], [String], [String], [String]))
-> [(String, AnyRelationship String String)]
-> [([String], [String], [String], [String], [String])]
forall a b. (a -> b) -> [a] -> [b]
map (String, AnyRelationship String String)
-> ([String], [String], [String], [String], [String])
forall {a} {className} {relationshipName} {className}
       {relationshipName}.
(a,
 Either
   (InvalidRelationship className relationshipName)
   (Relationship className relationshipName))
-> ([a], [a], [a], [a], [a])
nonInheritanceName [(String, AnyRelationship String String)]
namedRelationships
    nonInheritanceName :: (a,
 Either
   (InvalidRelationship className relationshipName)
   (Relationship className relationshipName))
-> ([a], [a], [a], [a], [a])
nonInheritanceName (a
name, Either
  (InvalidRelationship className relationshipName)
  (Relationship className relationshipName)
x) = case Either
  (InvalidRelationship className relationshipName)
  (Relationship className relationshipName)
x of
      Left InvalidInheritance {} -> ([a
name], [], [], [], [])
      Right Association {} -> ([], [a
name], [], [], [])
      Right Aggregation {} -> ([], [], [a
name], [], [])
      Right Composition {} -> ([], [], [], [a
name], [])
      Right Inheritance {} -> ([], [], [], [], [a
name])
    classSig :: String -> String
    classSig :: String -> String
classSig String
x = [i|one sig #{x} extends Class {}\n|]
    relationshipSig :: (String, AnyRelationship String relationship) -> String
    relationshipSig :: forall relationship.
(String, AnyRelationship String relationship) -> String
relationshipSig (String
name, AnyRelationship String relationship
x) = case AnyRelationship String relationship
x of
      Left InvalidInheritance {} -> [i|one sig #{name} extends InvalidInheritance {}\n|]
      Right Association {} -> [i|one sig #{name} extends Association {}\n|]
      Right Aggregation {} -> [i|one sig #{name} extends Aggregation {}\n|]
      Right Composition {} -> [i|one sig #{name} extends Composition {}\n|]
      Right Inheritance {} -> [i|one sig #{name} extends ValidInheritance {}\n|]
    relationshipConstraints :: (String,
 Either
   (InvalidRelationship String relationshipName)
   (Relationship String relationshipName))
-> String
relationshipConstraints (String
name, Either
  (InvalidRelationship String relationshipName)
  (Relationship String relationshipName)
x) = case Either
  (InvalidRelationship String relationshipName)
  (Relationship String relationshipName)
x of
      Left InvalidInheritance {LimitedLinking String
invalidSubClass :: LimitedLinking String
invalidSuperClass :: LimitedLinking String
invalidSubClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
invalidSuperClass :: forall className relationshipName.
InvalidRelationship className relationshipName
-> LimitedLinking className
..} -> String -> LimitedLinking String -> LimitedLinking String -> String
limitsConstraints String
name LimitedLinking String
invalidSubClass LimitedLinking String
invalidSuperClass
      Right Association {relationshipName
LimitedLinking String
associationName :: relationshipName
associationFrom :: LimitedLinking String
associationTo :: LimitedLinking String
associationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
associationFrom :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
associationTo :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
..} -> String -> LimitedLinking String -> LimitedLinking String -> String
limitsConstraints String
name LimitedLinking String
associationFrom LimitedLinking String
associationTo
      Right Aggregation {relationshipName
LimitedLinking String
aggregationName :: relationshipName
aggregationPart :: LimitedLinking String
aggregationWhole :: LimitedLinking String
aggregationName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
aggregationPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
aggregationWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
..} -> String -> LimitedLinking String -> LimitedLinking String -> String
limitsConstraints String
name LimitedLinking String
aggregationPart LimitedLinking String
aggregationWhole
      Right Composition {relationshipName
LimitedLinking String
compositionName :: relationshipName
compositionPart :: LimitedLinking String
compositionWhole :: LimitedLinking String
compositionName :: forall className relationshipName.
Relationship className relationshipName -> relationshipName
compositionPart :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
compositionWhole :: forall className relationshipName.
Relationship className relationshipName -> LimitedLinking className
..} -> String -> LimitedLinking String -> LimitedLinking String -> String
limitsConstraints String
name LimitedLinking String
compositionPart LimitedLinking String
compositionWhole
      Right Inheritance {String
subClass :: String
superClass :: String
subClass :: forall className relationshipName.
Relationship className relationshipName -> className
superClass :: forall className relationshipName.
Relationship className relationshipName -> className
..} -> [i|  #{name}.from = #{subClass}\n|]
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [i|  #{name}.to = #{superClass}\n|]
    limitsConstraints :: String -> LimitedLinking String -> LimitedLinking String -> String
limitsConstraints String
x LimitedLinking String
from LimitedLinking String
to =
      String -> String -> LimitedLinking String -> String
limitConstraints String
"from" String
x LimitedLinking String
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> LimitedLinking String -> String
limitConstraints String
"to" String
x LimitedLinking String
to
    limitConstraints :: String -> String -> LimitedLinking String -> String
    limitConstraints :: String -> String -> LimitedLinking String -> String
limitConstraints
      String
what
      String
x
      LimitedLinking {linking :: forall nodeName. LimitedLinking nodeName -> nodeName
linking = String
destination, limits :: forall nodeName. LimitedLinking nodeName -> (Int, Maybe Int)
limits = (Int
low, Maybe Int
high)} =
        [i|  #{x}.#{what} = #{destination}\n|]
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [i|  #{x}.#{what}Lower = #{limit low}\n|]
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [i|  #{x}.#{what}Upper = #{limit $ fromMaybe (-1) high}\n|]
    limit :: a -> String
limit a
0 = String
"Zero"
    limit a
1 = String
"One"
    limit a
2 = String
"Two"
    limit a
_ = String
"Star"

classDiagram :: ClassConfig -> CdConstraints -> RelationshipProperties -> String
classDiagram :: ClassConfig -> CdConstraints -> RelationshipProperties -> String
classDiagram ClassConfig
config CdConstraints {Maybe Bool
anyCompositionCyclesInvolveInheritances :: Maybe Bool
anyCompositionCyclesInvolveInheritances :: CdConstraints -> Maybe Bool
..} RelationshipProperties {Bool
Int
Maybe Bool
invalidInheritances :: Int
wrongNonInheritances :: Int
wrongCompositions :: Int
selfRelationshipsAmount :: Int
selfInheritancesAmount :: Int
hasDoubleRelationships :: Maybe Bool
hasReverseRelationships :: Maybe Bool
hasReverseInheritances :: Bool
hasMultipleInheritances :: Maybe Bool
hasNonTrivialInheritanceCycles :: Bool
hasCompositionCycles :: Bool
hasCompositionsPreventingParts :: Maybe Bool
hasThickEdges :: Maybe Bool
invalidInheritances :: RelationshipProperties -> Int
wrongNonInheritances :: RelationshipProperties -> Int
wrongCompositions :: RelationshipProperties -> Int
selfRelationshipsAmount :: RelationshipProperties -> Int
selfInheritancesAmount :: RelationshipProperties -> Int
hasDoubleRelationships :: RelationshipProperties -> Maybe Bool
hasReverseRelationships :: RelationshipProperties -> Maybe Bool
hasReverseInheritances :: RelationshipProperties -> Bool
hasMultipleInheritances :: RelationshipProperties -> Maybe Bool
hasNonTrivialInheritanceCycles :: RelationshipProperties -> Bool
hasCompositionCycles :: RelationshipProperties -> Bool
hasCompositionsPreventingParts :: RelationshipProperties -> Maybe Bool
hasThickEdges :: RelationshipProperties -> Maybe Bool
..} = [i|
//////////////////////////////////////////////////
// Basic CD
//////////////////////////////////////////////////

pred cd {
  let NonInheritance2 = NonInheritance - Change.add,
      Association2 = Association - Change.add,
      Aggregation2 = Aggregation - Change.add,
      Composition2 = Composition - Change.add,
      Relationship2 = Relationship - Change.add,
      Inheritance2 = Inheritance - Change.add {
    classDiagram [NonInheritance2, Composition2, Inheritance2, Relationship2,
      #{invalidInheritances},
      #{wrongNonInheritances},
      #{wrongCompositions},
      #{selfRelationshipsAmount},
      #{selfInheritancesAmount},
      #{maybeToAlloySet anyCompositionCyclesInvolveInheritances},
      #{maybeToAlloySet hasDoubleRelationships},
      #{maybeToAlloySet hasReverseRelationships},
      #{hasReverseInheritances},
      #{maybeToAlloySet hasMultipleInheritances},
      #{hasNonTrivialInheritanceCycles},
      #{hasCompositionCycles},
      #{maybeToAlloySet hasCompositionsPreventingParts},
      #{maybeToAlloySet hasThickEdges}]
    #{fst $ associationLimits config} <= \#Association2
    \#Association2 <= #{upper $ associationLimits config}
    #{fst $ aggregationLimits config} <= \#Aggregation2
    \#Aggregation2 <= #{upper $ aggregationLimits config}
    #{fst $ compositionLimits config} <= \#Composition2
    \#Composition2 <= #{upper $ compositionLimits config}
    #{fst $ inheritanceLimits config} <= \#Inheritance2
    \#Inheritance2 <= #{upper $ inheritanceLimits config}
    #{fst $ relationshipLimits config} <= \#Relationship2
    \#Relationship2 <= #{upper $ relationshipLimits config}
    #{fst $ classLimits config} <= \#Class
  }
}
|]
  where
    upper :: (a, Maybe Int) -> Int
upper = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (ClassConfig -> Int
maxRelationships ClassConfig
config) (Maybe Int -> Int)
-> ((a, Maybe Int) -> Maybe Int) -> (a, Maybe Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd

maybeToAlloySet :: Show a => Maybe a -> String
maybeToAlloySet :: forall a. Show a => Maybe a -> String
maybeToAlloySet = String -> (a -> String) -> Maybe a -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"none" a -> String
forall a. Show a => a -> String
show

changePredicate :: [CdMutation] -> String
changePredicate :: [CdMutation] -> String
changePredicate [] = [__i|
  pred change [c : Change, rs : set Relationship] {
    one c.add and no c.add
  }
  |]
changePredicate [CdMutation]
allowed = [__i|
  pred change [c : Change, rs : set Relationship] {
    some c.add + c.remove
    #{mutationConstraints}
    no c.add or not c.add in rs
    c.remove in rs
  }
  |]
  where
    mutationConstraints :: String
mutationConstraints = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" or "
      ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (CdMutation -> String) -> [CdMutation] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CdMutation -> String
changeConstraint ([CdMutation] -> [String]) -> [CdMutation] -> [String]
forall a b. (a -> b) -> a -> b
$ [CdMutation] -> [CdMutation]
forall a. Ord a => [a] -> [a]
nubOrd [CdMutation]
allowed
    changeConstraint :: CdMutation -> String
    changeConstraint :: CdMutation -> String
changeConstraint CdMutation
change = case CdMutation
change of
      CdMutation
AddRelationship -> [iii|one c.add and no c.remove|]
      MutateRelationship RelationshipMutation
mutation -> [iii|
        one c.add and one c.remove and #{mutationConstraint mutation}
        |]
      CdMutation
RemoveRelationship -> [iii|no c.add and one c.remove|]
    mutationConstraint :: RelationshipMutation -> String
    mutationConstraint :: RelationshipMutation -> String
mutationConstraint RelationshipMutation
mutation = case RelationshipMutation
mutation of
      RelationshipMutation
ChangeLimit -> [iii|changedLimit [c]|]
      RelationshipMutation
ChangeKind -> [iii|changedKind [c]|]
      RelationshipMutation
Flip -> [iii|flip [c]|]

changes
  :: Maybe ClassConfig
  -> CdConstraints
  -> [RelationshipProperties]
  -> (Int, [String], String)
changes :: Maybe ClassConfig
-> CdConstraints
-> [RelationshipProperties]
-> (Int, [String], String)
changes Maybe ClassConfig
config CdConstraints
cdConstraints [RelationshipProperties]
propsList = ([String] -> String -> (Int, [String], String))
-> ([String], String) -> (Int, [String], String)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([RelationshipProperties] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RelationshipProperties]
propsList,,)
  (([String], String) -> (Int, [String], String))
-> ([String], String) -> (Int, [String], String)
forall a b. (a -> b) -> a -> b
$ (Int, ([String], String)) -> ([String], String)
forall a b. (a, b) -> b
snd ((Int, ([String], String)) -> ([String], String))
-> (Int, ([String], String)) -> ([String], String)
forall a b. (a -> b) -> a -> b
$ ((Int, ([String], String))
 -> RelationshipProperties -> (Int, ([String], String)))
-> (Int, ([String], String))
-> [RelationshipProperties]
-> (Int, ([String], String))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Int, ([String], String))
-> RelationshipProperties -> (Int, ([String], String))
change (Int
1, ([String], String)
limits) [RelationshipProperties]
propsList
  where
    change :: (Int, ([String], String))
-> RelationshipProperties -> (Int, ([String], String))
change (Int
n, ([String]
cs, String
code)) RelationshipProperties
p =
      let (String
c, String
code') = CdConstraints -> RelationshipProperties -> Int -> (String, String)
changeWithProperties CdConstraints
cdConstraints RelationshipProperties
p Int
n
      in (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
cs, String
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
code'))
    limits :: ([String], String)
limits = ([String], String)
-> (ClassConfig -> ([String], String))
-> Maybe ClassConfig
-> ([String], String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      ([], String
header)
      (([String
"changeLimits"],) (String -> ([String], String))
-> (ClassConfig -> String) -> ClassConfig -> ([String], String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassConfig -> String
changeLimits)
      Maybe ClassConfig
config
    header :: String
header = [i|
//////////////////////////////////////////////////
// Changes
//////////////////////////////////////////////////
|]

{-|
Generates Alloy code for the changeOfFirstCD predicate.
-}
changeWithProperties
  :: CdConstraints
  -- ^ additional properties
  -> RelationshipProperties
  -- ^ properties of the specific change
  -> Int
  -- ^ an unique index number for the change
  -> (String, String)
changeWithProperties :: CdConstraints -> RelationshipProperties -> Int -> (String, String)
changeWithProperties CdConstraints {Maybe Bool
anyCompositionCyclesInvolveInheritances :: CdConstraints -> Maybe Bool
anyCompositionCyclesInvolveInheritances :: Maybe Bool
..} RelationshipProperties {Bool
Int
Maybe Bool
invalidInheritances :: RelationshipProperties -> Int
wrongNonInheritances :: RelationshipProperties -> Int
wrongCompositions :: RelationshipProperties -> Int
selfRelationshipsAmount :: RelationshipProperties -> Int
selfInheritancesAmount :: RelationshipProperties -> Int
hasDoubleRelationships :: RelationshipProperties -> Maybe Bool
hasReverseRelationships :: RelationshipProperties -> Maybe Bool
hasReverseInheritances :: RelationshipProperties -> Bool
hasMultipleInheritances :: RelationshipProperties -> Maybe Bool
hasNonTrivialInheritanceCycles :: RelationshipProperties -> Bool
hasCompositionCycles :: RelationshipProperties -> Bool
hasCompositionsPreventingParts :: RelationshipProperties -> Maybe Bool
hasThickEdges :: RelationshipProperties -> Maybe Bool
invalidInheritances :: Int
wrongNonInheritances :: Int
wrongCompositions :: Int
selfRelationshipsAmount :: Int
selfInheritancesAmount :: Int
hasDoubleRelationships :: Maybe Bool
hasReverseRelationships :: Maybe Bool
hasReverseInheritances :: Bool
hasMultipleInheritances :: Maybe Bool
hasNonTrivialInheritanceCycles :: Bool
hasCompositionCycles :: Bool
hasCompositionsPreventingParts :: Maybe Bool
hasThickEdges :: Maybe Bool
..} Int
n
  = (String
change, String
alloy)
  where
    change :: String
change = [i|change#{n}|]
    alloy :: String
alloy =  [i|
sig C#{n} extends Change {}

pred #{change} {
  changeOfFirstCD [
    C#{n},
    #{invalidInheritances},
    #{wrongNonInheritances},
    #{wrongCompositions},
    #{selfRelationshipsAmount},
    #{selfInheritancesAmount},
    #{maybeToAlloySet anyCompositionCyclesInvolveInheritances},
    #{maybeToAlloySet hasDoubleRelationships},
    #{maybeToAlloySet hasReverseRelationships},
    #{hasReverseInheritances},
    #{maybeToAlloySet hasMultipleInheritances},
    #{hasNonTrivialInheritanceCycles},
    #{hasCompositionCycles},
    #{maybeToAlloySet hasCompositionsPreventingParts},
    #{maybeToAlloySet hasThickEdges}]
}
|]

matchCdOdChanges
  :: ClassConfig
  -> Maybe Bool
  -> (Int, [String], String)
matchCdOdChanges :: ClassConfig -> Maybe Bool -> (Int, [String], String)
matchCdOdChanges ClassConfig
config Maybe Bool
withNonTrivialInheritance =
  (Int
3, [String
"changes", String
"changeLimits"],) (String -> (Int, [String], String))
-> String -> (Int, [String], String)
forall a b. (a -> b) -> a -> b
$ [i|
//////////////////////////////////////////////////
// Changes
//////////////////////////////////////////////////
sig C1, C2, C3 extends Change {}

pred changes {
    let c1NonInheritances = NonInheritance - (Change.add - NonInheritance <: C1.add) - C1.remove,
        c2NonInheritances = NonInheritance - (Change.add - NonInheritance <: C2.add) - C2.remove {
      some c1NonInheritances or some c2NonInheritances
      let c1Inheritances = Inheritance - (Change.add - Inheritance <: C1.add) - C1.remove,
          c2Inheritances = Inheritance - (Change.add - Inheritance <: C2.add) - C2.remove {
        #{nonTrivialInheritanceConstraint "c1Inheritances" "c1NonInheritances" withNonTrivialInheritance}
        #{nonTrivialInheritanceConstraint "c2Inheritances" "c2NonInheritances" withNonTrivialInheritance}
      }
    }
    changeOfFirstCD [C1, 0, 0, 0, 0, 0, none, False, False, False, False, False, False, False, none]
    changeOfFirstCD [C2, 0, 0, 0, 0, 0, none, False, False, False, False, False, False, False, none]
    changeOfFirstCD [C3, 0, 0, 0, 0, 0, none, False, False, False, False, False, False, False, none]
}
|] String -> String -> String
forall a. [a] -> [a] -> [a]
++ ClassConfig -> String
changeLimits ClassConfig
config

changeLimits :: ClassConfig -> String
changeLimits :: ClassConfig -> String
changeLimits ClassConfig
config = [i|
pred changeLimits {
  all c : Change {
    let Association2 = Association - (Change.add - c.add) - c.remove,
        Composition2 = Composition - (Change.add - c.add) - c.remove,
        Aggregation2 = Aggregation - (Change.add - c.add) - c.remove,
        Inheritance2 = Inheritance - (Change.add - c.add) - c.remove {
      #{fst $ associationLimits config} <= \#Association2
      \#Association2 <= #{upper $ associationLimits config}
      #{fst $ aggregationLimits config} <= \#Aggregation2
      \#Aggregation2 <= #{upper $ aggregationLimits config}
      #{fst $ compositionLimits config} <= \#Composition2
      \#Composition2 <= #{upper $ compositionLimits config}
      #{fst $ inheritanceLimits config} <= \#Inheritance2
      \#Inheritance2 <= #{upper $ inheritanceLimits config}
    }
  }
}
|]
  where
    upper :: (a, Maybe Int) -> Int
upper = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (ClassConfig -> Int
maxRelationships ClassConfig
config) (Maybe Int -> Int)
-> ((a, Maybe Int) -> Maybe Int) -> (a, Maybe Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd

createRunCommand :: ClassConfig -> [String] -> Int ->  String
createRunCommand :: ClassConfig -> [String] -> Int -> String
createRunCommand config :: ClassConfig
config@ClassConfig {(Int, Int)
(Int, Maybe Int)
classLimits :: ClassConfig -> (Int, Int)
aggregationLimits :: ClassConfig -> (Int, Maybe Int)
associationLimits :: ClassConfig -> (Int, Maybe Int)
compositionLimits :: ClassConfig -> (Int, Maybe Int)
inheritanceLimits :: ClassConfig -> (Int, Maybe Int)
relationshipLimits :: ClassConfig -> (Int, Maybe Int)
classLimits :: (Int, Int)
aggregationLimits :: (Int, Maybe Int)
associationLimits :: (Int, Maybe Int)
compositionLimits :: (Int, Maybe Int)
inheritanceLimits :: (Int, Maybe Int)
relationshipLimits :: (Int, Maybe Int)
..} [String]
predicates Int
cs = [i|
run { #{command} } for #{relationships} Relationship, #{bitSize} Int,
  #{exactClass}#{snd classLimits} Class, exactly #{cs} Change
|]
  where
    exactClass :: String
exactClass
      | (Int -> Int -> Bool) -> (Int, Int) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int, Int)
classLimits = String
"exactly "
      | Bool
otherwise            = String
""
    relMax :: Int
relMax = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (ClassConfig -> Int
maxRelationships ClassConfig
config) (Maybe Int -> Int)
-> ((Int, Maybe Int) -> Maybe Int) -> (Int, Maybe Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd ((Int, Maybe Int) -> Int) -> (Int, Maybe Int) -> Int
forall a b. (a -> b) -> a -> b
$ (Int, Maybe Int)
relationshipLimits
    relationships :: Int
relationships = Int
relMax Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cs
    bitSize :: Int
    bitSize :: Int
bitSize = (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
ceiling @Double (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
relationships ((Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
classLimits) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    command :: String
    command :: String
command = (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> String -> String)
-> (String -> String) -> String -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and ")) String
"cd" [String]
predicates

removeLines :: Int -> String -> String
removeLines :: Int -> String -> String
removeLines Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1     = String -> String
forall a. a -> a
id
  | Bool
otherwise = Int -> String -> String
removeLines (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
removeLine

removeLine :: String -> String
removeLine :: String -> String
removeLine = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')