{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Modelling.CdOd.CdAndChanges.Instance (
  AnnotatedChangeAndCd (..),
  ChangeAndCd (..),
  ClassDiagramInstance,
  GenericClassDiagramInstance (..),
  ReadObjectDiagramFromAlloyException (..),
  UnexpectedRelation (..),
  fromInstance,
  fromInstanceWithNameOverlap,
  fromInstanceWithPredefinedNames,
  nameClassDiagramInstance,
  uniformlyAnnotateChangeAndCd,
  validChangeClassDiagram,
  ) where

import qualified Data.Bimap                       as BM (fromList, lookup)
import qualified Data.Map                         as M (
  lookup,
  )
import qualified Data.Set                         as S (
  findMin,
  size,
  toList,
  )

import Modelling.Auxiliary.Common       (Object (Object, oName), toMap)
import Modelling.CdOd.Types (
  Annotation (..),
  AnyClassDiagram (..),
  AnyRelationship,
  ClassDiagram,
  InvalidRelationship (..),
  LimitedLinking (..),
  Relationship (..),
  anyRelationshipName,
  toValidCd,
  )
import Modelling.Types                  (Change (..))

import Control.Monad                    ((<=<), forM)
import Control.Monad.Catch              (Exception, MonadThrow (throwM))
import Data.Bifunctor                   (Bifunctor (bimap, second))
import Data.Bifunctor.TH (
  deriveBifoldable,
  deriveBifunctor,
  deriveBitraversable,
  )
import Data.Bifoldable                  (Bifoldable (bifoldMap))
import Data.Bimap                       (Bimap)
import Data.Bitraversable               (Bitraversable (bitraverse))
import Data.Composition                 ((.:))
import Data.Map                         (Map)
import Data.Maybe (
  fromMaybe,
  isJust,
  mapMaybe,
  maybeToList,
  )
import Data.Typeable                    (Typeable)
import Language.Alloy.Call (
  AlloyInstance,
  AlloySig,
  getDoubleAs,
  getSingleAs,
  lookupSig,
  scoped,
  )

objectName :: Object -> String
objectName :: Object -> String
objectName (Object String
n Int
x) = String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'$' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
x

newtype NumberedClass = NumberedClass Int
  deriving (NumberedClass -> NumberedClass -> Bool
(NumberedClass -> NumberedClass -> Bool)
-> (NumberedClass -> NumberedClass -> Bool) -> Eq NumberedClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumberedClass -> NumberedClass -> Bool
== :: NumberedClass -> NumberedClass -> Bool
$c/= :: NumberedClass -> NumberedClass -> Bool
/= :: NumberedClass -> NumberedClass -> Bool
Eq, Eq NumberedClass
Eq NumberedClass
-> (NumberedClass -> NumberedClass -> Ordering)
-> (NumberedClass -> NumberedClass -> Bool)
-> (NumberedClass -> NumberedClass -> Bool)
-> (NumberedClass -> NumberedClass -> Bool)
-> (NumberedClass -> NumberedClass -> Bool)
-> (NumberedClass -> NumberedClass -> NumberedClass)
-> (NumberedClass -> NumberedClass -> NumberedClass)
-> Ord NumberedClass
NumberedClass -> NumberedClass -> Bool
NumberedClass -> NumberedClass -> Ordering
NumberedClass -> NumberedClass -> NumberedClass
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NumberedClass -> NumberedClass -> Ordering
compare :: NumberedClass -> NumberedClass -> Ordering
$c< :: NumberedClass -> NumberedClass -> Bool
< :: NumberedClass -> NumberedClass -> Bool
$c<= :: NumberedClass -> NumberedClass -> Bool
<= :: NumberedClass -> NumberedClass -> Bool
$c> :: NumberedClass -> NumberedClass -> Bool
> :: NumberedClass -> NumberedClass -> Bool
$c>= :: NumberedClass -> NumberedClass -> Bool
>= :: NumberedClass -> NumberedClass -> Bool
$cmax :: NumberedClass -> NumberedClass -> NumberedClass
max :: NumberedClass -> NumberedClass -> NumberedClass
$cmin :: NumberedClass -> NumberedClass -> NumberedClass
min :: NumberedClass -> NumberedClass -> NumberedClass
Ord)

data NumberedNonInheritance = NumberedNonInheritance String Int
  deriving (NumberedNonInheritance -> NumberedNonInheritance -> Bool
(NumberedNonInheritance -> NumberedNonInheritance -> Bool)
-> (NumberedNonInheritance -> NumberedNonInheritance -> Bool)
-> Eq NumberedNonInheritance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
== :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
$c/= :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
/= :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
Eq, Eq NumberedNonInheritance
Eq NumberedNonInheritance
-> (NumberedNonInheritance -> NumberedNonInheritance -> Ordering)
-> (NumberedNonInheritance -> NumberedNonInheritance -> Bool)
-> (NumberedNonInheritance -> NumberedNonInheritance -> Bool)
-> (NumberedNonInheritance -> NumberedNonInheritance -> Bool)
-> (NumberedNonInheritance -> NumberedNonInheritance -> Bool)
-> (NumberedNonInheritance
    -> NumberedNonInheritance -> NumberedNonInheritance)
-> (NumberedNonInheritance
    -> NumberedNonInheritance -> NumberedNonInheritance)
-> Ord NumberedNonInheritance
NumberedNonInheritance -> NumberedNonInheritance -> Bool
NumberedNonInheritance -> NumberedNonInheritance -> Ordering
NumberedNonInheritance
-> NumberedNonInheritance -> NumberedNonInheritance
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NumberedNonInheritance -> NumberedNonInheritance -> Ordering
compare :: NumberedNonInheritance -> NumberedNonInheritance -> Ordering
$c< :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
< :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
$c<= :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
<= :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
$c> :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
> :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
$c>= :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
>= :: NumberedNonInheritance -> NumberedNonInheritance -> Bool
$cmax :: NumberedNonInheritance
-> NumberedNonInheritance -> NumberedNonInheritance
max :: NumberedNonInheritance
-> NumberedNonInheritance -> NumberedNonInheritance
$cmin :: NumberedNonInheritance
-> NumberedNonInheritance -> NumberedNonInheritance
min :: NumberedNonInheritance
-> NumberedNonInheritance -> NumberedNonInheritance
Ord)

data AnnotatedChangeAndCd annotation className relationshipName
  = AnnotatedChangeAndCd {
    forall annotation className relationshipName.
AnnotatedChangeAndCd annotation className relationshipName
-> Annotation
     annotation (Change (AnyRelationship className relationshipName))
annotatedRelationshipChange
      :: !(Annotation
        annotation
        (Change (AnyRelationship className relationshipName))),
    forall annotation className relationshipName.
AnnotatedChangeAndCd annotation className relationshipName
-> AnyClassDiagram className relationshipName
annotatedChangeClassDiagram
      :: !(AnyClassDiagram className relationshipName)
    }
  deriving (ReadPrec
  [AnnotatedChangeAndCd annotation className relationshipName]
ReadPrec
  (AnnotatedChangeAndCd annotation className relationshipName)
Int
-> ReadS
     (AnnotatedChangeAndCd annotation className relationshipName)
ReadS [AnnotatedChangeAndCd annotation className relationshipName]
(Int
 -> ReadS
      (AnnotatedChangeAndCd annotation className relationshipName))
-> ReadS
     [AnnotatedChangeAndCd annotation className relationshipName]
-> ReadPrec
     (AnnotatedChangeAndCd annotation className relationshipName)
-> ReadPrec
     [AnnotatedChangeAndCd annotation className relationshipName]
-> Read
     (AnnotatedChangeAndCd annotation className relationshipName)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
ReadPrec
  [AnnotatedChangeAndCd annotation className relationshipName]
forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
ReadPrec
  (AnnotatedChangeAndCd annotation className relationshipName)
forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
Int
-> ReadS
     (AnnotatedChangeAndCd annotation className relationshipName)
forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
ReadS [AnnotatedChangeAndCd annotation className relationshipName]
$creadsPrec :: forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
Int
-> ReadS
     (AnnotatedChangeAndCd annotation className relationshipName)
readsPrec :: Int
-> ReadS
     (AnnotatedChangeAndCd annotation className relationshipName)
$creadList :: forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
ReadS [AnnotatedChangeAndCd annotation className relationshipName]
readList :: ReadS [AnnotatedChangeAndCd annotation className relationshipName]
$creadPrec :: forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
ReadPrec
  (AnnotatedChangeAndCd annotation className relationshipName)
readPrec :: ReadPrec
  (AnnotatedChangeAndCd annotation className relationshipName)
$creadListPrec :: forall annotation className relationshipName.
(Read className, Read relationshipName, Read annotation) =>
ReadPrec
  [AnnotatedChangeAndCd annotation className relationshipName]
readListPrec :: ReadPrec
  [AnnotatedChangeAndCd annotation className relationshipName]
Read, Int
-> AnnotatedChangeAndCd annotation className relationshipName
-> String
-> String
[AnnotatedChangeAndCd annotation className relationshipName]
-> String -> String
AnnotatedChangeAndCd annotation className relationshipName
-> String
(Int
 -> AnnotatedChangeAndCd annotation className relationshipName
 -> String
 -> String)
-> (AnnotatedChangeAndCd annotation className relationshipName
    -> String)
-> ([AnnotatedChangeAndCd annotation className relationshipName]
    -> String -> String)
-> Show
     (AnnotatedChangeAndCd annotation className relationshipName)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall annotation className relationshipName.
(Show className, Show relationshipName, Show annotation) =>
Int
-> AnnotatedChangeAndCd annotation className relationshipName
-> String
-> String
forall annotation className relationshipName.
(Show className, Show relationshipName, Show annotation) =>
[AnnotatedChangeAndCd annotation className relationshipName]
-> String -> String
forall annotation className relationshipName.
(Show className, Show relationshipName, Show annotation) =>
AnnotatedChangeAndCd annotation className relationshipName
-> String
$cshowsPrec :: forall annotation className relationshipName.
(Show className, Show relationshipName, Show annotation) =>
Int
-> AnnotatedChangeAndCd annotation className relationshipName
-> String
-> String
showsPrec :: Int
-> AnnotatedChangeAndCd annotation className relationshipName
-> String
-> String
$cshow :: forall annotation className relationshipName.
(Show className, Show relationshipName, Show annotation) =>
AnnotatedChangeAndCd annotation className relationshipName
-> String
show :: AnnotatedChangeAndCd annotation className relationshipName
-> String
$cshowList :: forall annotation className relationshipName.
(Show className, Show relationshipName, Show annotation) =>
[AnnotatedChangeAndCd annotation className relationshipName]
-> String -> String
showList :: [AnnotatedChangeAndCd annotation className relationshipName]
-> String -> String
Show)

data ChangeAndCd className relationshipName
  = ChangeAndCd {
    forall className relationshipName.
ChangeAndCd className relationshipName
-> Change (AnyRelationship className relationshipName)
relationshipChange
      :: !(Change (AnyRelationship className relationshipName)),
    forall className relationshipName.
ChangeAndCd className relationshipName
-> AnyClassDiagram className relationshipName
changeClassDiagram
      :: !(AnyClassDiagram className relationshipName)
    }
  deriving (ReadPrec [ChangeAndCd className relationshipName]
ReadPrec (ChangeAndCd className relationshipName)
Int -> ReadS (ChangeAndCd className relationshipName)
ReadS [ChangeAndCd className relationshipName]
(Int -> ReadS (ChangeAndCd className relationshipName))
-> ReadS [ChangeAndCd className relationshipName]
-> ReadPrec (ChangeAndCd className relationshipName)
-> ReadPrec [ChangeAndCd className relationshipName]
-> Read (ChangeAndCd className relationshipName)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec [ChangeAndCd className relationshipName]
forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec (ChangeAndCd className relationshipName)
forall className relationshipName.
(Read className, Read relationshipName) =>
Int -> ReadS (ChangeAndCd className relationshipName)
forall className relationshipName.
(Read className, Read relationshipName) =>
ReadS [ChangeAndCd className relationshipName]
$creadsPrec :: forall className relationshipName.
(Read className, Read relationshipName) =>
Int -> ReadS (ChangeAndCd className relationshipName)
readsPrec :: Int -> ReadS (ChangeAndCd className relationshipName)
$creadList :: forall className relationshipName.
(Read className, Read relationshipName) =>
ReadS [ChangeAndCd className relationshipName]
readList :: ReadS [ChangeAndCd className relationshipName]
$creadPrec :: forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec (ChangeAndCd className relationshipName)
readPrec :: ReadPrec (ChangeAndCd className relationshipName)
$creadListPrec :: forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec [ChangeAndCd className relationshipName]
readListPrec :: ReadPrec [ChangeAndCd className relationshipName]
Read, Int -> ChangeAndCd className relationshipName -> String -> String
[ChangeAndCd className relationshipName] -> String -> String
ChangeAndCd className relationshipName -> String
(Int -> ChangeAndCd className relationshipName -> String -> String)
-> (ChangeAndCd className relationshipName -> String)
-> ([ChangeAndCd className relationshipName] -> String -> String)
-> Show (ChangeAndCd className relationshipName)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall className relationshipName.
(Show className, Show relationshipName) =>
Int -> ChangeAndCd className relationshipName -> String -> String
forall className relationshipName.
(Show className, Show relationshipName) =>
[ChangeAndCd className relationshipName] -> String -> String
forall className relationshipName.
(Show className, Show relationshipName) =>
ChangeAndCd className relationshipName -> String
$cshowsPrec :: forall className relationshipName.
(Show className, Show relationshipName) =>
Int -> ChangeAndCd className relationshipName -> String -> String
showsPrec :: Int -> ChangeAndCd className relationshipName -> String -> String
$cshow :: forall className relationshipName.
(Show className, Show relationshipName) =>
ChangeAndCd className relationshipName -> String
show :: ChangeAndCd className relationshipName -> String
$cshowList :: forall className relationshipName.
(Show className, Show relationshipName) =>
[ChangeAndCd className relationshipName] -> String -> String
showList :: [ChangeAndCd className relationshipName] -> String -> String
Show)

instance Functor (ChangeAndCd className) where
  fmap :: forall a b.
(a -> b) -> ChangeAndCd className a -> ChangeAndCd className b
fmap a -> b
f ChangeAndCd {AnyClassDiagram className a
Change (AnyRelationship className a)
relationshipChange :: forall className relationshipName.
ChangeAndCd className relationshipName
-> Change (AnyRelationship className relationshipName)
changeClassDiagram :: forall className relationshipName.
ChangeAndCd className relationshipName
-> AnyClassDiagram className relationshipName
relationshipChange :: Change (AnyRelationship className a)
changeClassDiagram :: AnyClassDiagram className a
..} = ChangeAndCd {
    relationshipChange :: Change (AnyRelationship className b)
relationshipChange = (AnyRelationship className a -> AnyRelationship className b)
-> Change (AnyRelationship className a)
-> Change (AnyRelationship className b)
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InvalidRelationship className a
 -> InvalidRelationship className b)
-> (Relationship className a -> Relationship className b)
-> AnyRelationship className a
-> AnyRelationship className b
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((a -> b)
-> InvalidRelationship className a
-> InvalidRelationship className b
forall a b.
(a -> b)
-> InvalidRelationship className a
-> InvalidRelationship className b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) ((a -> b) -> Relationship className a -> Relationship className b
forall a b.
(a -> b) -> Relationship className a -> Relationship className b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) Change (AnyRelationship className a)
relationshipChange,
    changeClassDiagram :: AnyClassDiagram className b
changeClassDiagram = (a -> b)
-> AnyClassDiagram className a -> AnyClassDiagram className b
forall a b.
(a -> b)
-> AnyClassDiagram className a -> AnyClassDiagram className b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f AnyClassDiagram className a
changeClassDiagram
    }

$(deriveBifunctor ''ChangeAndCd)
$(deriveBifoldable ''ChangeAndCd)
$(deriveBitraversable ''ChangeAndCd)

validChangeClassDiagram
  :: (
    Eq className,
    MonadThrow m,
    Show className,
    Show relationshipName,
    Typeable className,
    Typeable relationshipName
    )
  => ChangeAndCd className relationshipName
  -> m (ClassDiagram className relationshipName)
validChangeClassDiagram :: forall className (m :: * -> *) relationshipName.
(Eq className, MonadThrow m, Show className, Show relationshipName,
 Typeable className, Typeable relationshipName) =>
ChangeAndCd className relationshipName
-> m (ClassDiagram className relationshipName)
validChangeClassDiagram = AnyClassDiagram className relationshipName
-> m (ClassDiagram className relationshipName)
forall className (m :: * -> *) relationshipName.
(Eq className, MonadThrow m, Show className, Show relationshipName,
 Typeable className, Typeable relationshipName) =>
AnyClassDiagram className relationshipName
-> m (ClassDiagram className relationshipName)
toValidCd (AnyClassDiagram className relationshipName
 -> m (ClassDiagram className relationshipName))
-> (ChangeAndCd className relationshipName
    -> AnyClassDiagram className relationshipName)
-> ChangeAndCd className relationshipName
-> m (ClassDiagram className relationshipName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangeAndCd className relationshipName
-> AnyClassDiagram className relationshipName
forall className relationshipName.
ChangeAndCd className relationshipName
-> AnyClassDiagram className relationshipName
changeClassDiagram

uniformlyAnnotateChangeAndCd
  :: annotation
  -> ChangeAndCd className relationshipName
  -> AnnotatedChangeAndCd annotation className relationshipName
uniformlyAnnotateChangeAndCd :: forall annotation className relationshipName.
annotation
-> ChangeAndCd className relationshipName
-> AnnotatedChangeAndCd annotation className relationshipName
uniformlyAnnotateChangeAndCd annotation
annotation ChangeAndCd {AnyClassDiagram className relationshipName
Change (AnyRelationship className relationshipName)
relationshipChange :: forall className relationshipName.
ChangeAndCd className relationshipName
-> Change (AnyRelationship className relationshipName)
changeClassDiagram :: forall className relationshipName.
ChangeAndCd className relationshipName
-> AnyClassDiagram className relationshipName
relationshipChange :: Change (AnyRelationship className relationshipName)
changeClassDiagram :: AnyClassDiagram className relationshipName
..} = AnnotatedChangeAndCd {
  annotatedRelationshipChange :: Annotation
  annotation (Change (AnyRelationship className relationshipName))
annotatedRelationshipChange = Annotation {
    annotated :: Change (AnyRelationship className relationshipName)
annotated = Change (AnyRelationship className relationshipName)
relationshipChange,
    annotation :: annotation
annotation = annotation
annotation
    },
  annotatedChangeClassDiagram :: AnyClassDiagram className relationshipName
annotatedChangeClassDiagram = AnyClassDiagram className relationshipName
changeClassDiagram
  }

data GenericClassDiagramInstance className relationshipName
  = ClassDiagramInstance {
    forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
instanceClassDiagram      :: !(AnyClassDiagram className relationshipName),
    forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [relationshipName]
instanceRelationshipNames :: [relationshipName],
    forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [ChangeAndCd className relationshipName]
instanceChangesAndCds     :: [ChangeAndCd className relationshipName]
    }
  deriving ((forall a b.
 (a -> b)
 -> GenericClassDiagramInstance className a
 -> GenericClassDiagramInstance className b)
-> (forall a b.
    a
    -> GenericClassDiagramInstance className b
    -> GenericClassDiagramInstance className a)
-> Functor (GenericClassDiagramInstance className)
forall a b.
a
-> GenericClassDiagramInstance className b
-> GenericClassDiagramInstance className a
forall a b.
(a -> b)
-> GenericClassDiagramInstance className a
-> GenericClassDiagramInstance className b
forall className a b.
a
-> GenericClassDiagramInstance className b
-> GenericClassDiagramInstance className a
forall className a b.
(a -> b)
-> GenericClassDiagramInstance className a
-> GenericClassDiagramInstance className b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall className a b.
(a -> b)
-> GenericClassDiagramInstance className a
-> GenericClassDiagramInstance className b
fmap :: forall a b.
(a -> b)
-> GenericClassDiagramInstance className a
-> GenericClassDiagramInstance className b
$c<$ :: forall className a b.
a
-> GenericClassDiagramInstance className b
-> GenericClassDiagramInstance className a
<$ :: forall a b.
a
-> GenericClassDiagramInstance className b
-> GenericClassDiagramInstance className a
Functor, ReadPrec [GenericClassDiagramInstance className relationshipName]
ReadPrec (GenericClassDiagramInstance className relationshipName)
Int
-> ReadS (GenericClassDiagramInstance className relationshipName)
ReadS [GenericClassDiagramInstance className relationshipName]
(Int
 -> ReadS (GenericClassDiagramInstance className relationshipName))
-> ReadS [GenericClassDiagramInstance className relationshipName]
-> ReadPrec
     (GenericClassDiagramInstance className relationshipName)
-> ReadPrec
     [GenericClassDiagramInstance className relationshipName]
-> Read (GenericClassDiagramInstance className relationshipName)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec [GenericClassDiagramInstance className relationshipName]
forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec (GenericClassDiagramInstance className relationshipName)
forall className relationshipName.
(Read className, Read relationshipName) =>
Int
-> ReadS (GenericClassDiagramInstance className relationshipName)
forall className relationshipName.
(Read className, Read relationshipName) =>
ReadS [GenericClassDiagramInstance className relationshipName]
$creadsPrec :: forall className relationshipName.
(Read className, Read relationshipName) =>
Int
-> ReadS (GenericClassDiagramInstance className relationshipName)
readsPrec :: Int
-> ReadS (GenericClassDiagramInstance className relationshipName)
$creadList :: forall className relationshipName.
(Read className, Read relationshipName) =>
ReadS [GenericClassDiagramInstance className relationshipName]
readList :: ReadS [GenericClassDiagramInstance className relationshipName]
$creadPrec :: forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec (GenericClassDiagramInstance className relationshipName)
readPrec :: ReadPrec (GenericClassDiagramInstance className relationshipName)
$creadListPrec :: forall className relationshipName.
(Read className, Read relationshipName) =>
ReadPrec [GenericClassDiagramInstance className relationshipName]
readListPrec :: ReadPrec [GenericClassDiagramInstance className relationshipName]
Read, Int
-> GenericClassDiagramInstance className relationshipName
-> String
-> String
[GenericClassDiagramInstance className relationshipName]
-> String -> String
GenericClassDiagramInstance className relationshipName -> String
(Int
 -> GenericClassDiagramInstance className relationshipName
 -> String
 -> String)
-> (GenericClassDiagramInstance className relationshipName
    -> String)
-> ([GenericClassDiagramInstance className relationshipName]
    -> String -> String)
-> Show (GenericClassDiagramInstance className relationshipName)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall className relationshipName.
(Show className, Show relationshipName) =>
Int
-> GenericClassDiagramInstance className relationshipName
-> String
-> String
forall className relationshipName.
(Show className, Show relationshipName) =>
[GenericClassDiagramInstance className relationshipName]
-> String -> String
forall className relationshipName.
(Show className, Show relationshipName) =>
GenericClassDiagramInstance className relationshipName -> String
$cshowsPrec :: forall className relationshipName.
(Show className, Show relationshipName) =>
Int
-> GenericClassDiagramInstance className relationshipName
-> String
-> String
showsPrec :: Int
-> GenericClassDiagramInstance className relationshipName
-> String
-> String
$cshow :: forall className relationshipName.
(Show className, Show relationshipName) =>
GenericClassDiagramInstance className relationshipName -> String
show :: GenericClassDiagramInstance className relationshipName -> String
$cshowList :: forall className relationshipName.
(Show className, Show relationshipName) =>
[GenericClassDiagramInstance className relationshipName]
-> String -> String
showList :: [GenericClassDiagramInstance className relationshipName]
-> String -> String
Show)

instance Bifunctor GenericClassDiagramInstance where
  bimap :: forall a b c d.
(a -> b)
-> (c -> d)
-> GenericClassDiagramInstance a c
-> GenericClassDiagramInstance b d
bimap a -> b
f c -> d
g ClassDiagramInstance {[c]
[ChangeAndCd a c]
AnyClassDiagram a c
instanceClassDiagram :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
instanceRelationshipNames :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [relationshipName]
instanceChangesAndCds :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [ChangeAndCd className relationshipName]
instanceClassDiagram :: AnyClassDiagram a c
instanceRelationshipNames :: [c]
instanceChangesAndCds :: [ChangeAndCd a c]
..} = ClassDiagramInstance {
    instanceClassDiagram :: AnyClassDiagram b d
instanceClassDiagram = (a -> b) -> (c -> d) -> AnyClassDiagram a c -> AnyClassDiagram b d
forall a b c d.
(a -> b) -> (c -> d) -> AnyClassDiagram a c -> AnyClassDiagram b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g AnyClassDiagram a c
instanceClassDiagram,
    instanceRelationshipNames :: [d]
instanceRelationshipNames = (c -> d) -> [c] -> [d]
forall a b. (a -> b) -> [a] -> [b]
map c -> d
g [c]
instanceRelationshipNames,
    instanceChangesAndCds :: [ChangeAndCd b d]
instanceChangesAndCds = (ChangeAndCd a c -> ChangeAndCd b d)
-> [ChangeAndCd a c] -> [ChangeAndCd b d]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> (c -> d) -> ChangeAndCd a c -> ChangeAndCd b d
forall a b c d.
(a -> b) -> (c -> d) -> ChangeAndCd a c -> ChangeAndCd b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g) [ChangeAndCd a c]
instanceChangesAndCds
    }

instance Bifoldable GenericClassDiagramInstance where
  bifoldMap :: forall m a b.
Monoid m =>
(a -> m) -> (b -> m) -> GenericClassDiagramInstance a b -> m
bifoldMap a -> m
f b -> m
g ClassDiagramInstance {[b]
[ChangeAndCd a b]
AnyClassDiagram a b
instanceClassDiagram :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
instanceRelationshipNames :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [relationshipName]
instanceChangesAndCds :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [ChangeAndCd className relationshipName]
instanceClassDiagram :: AnyClassDiagram a b
instanceRelationshipNames :: [b]
instanceChangesAndCds :: [ChangeAndCd a b]
..} = (a -> m) -> (b -> m) -> AnyClassDiagram a b -> m
forall m a b.
Monoid m =>
(a -> m) -> (b -> m) -> AnyClassDiagram a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f b -> m
g AnyClassDiagram a b
instanceClassDiagram
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (b -> m) -> [b] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> m
g [b]
instanceRelationshipNames
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (ChangeAndCd a b -> m) -> [ChangeAndCd a b] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> (b -> m) -> ChangeAndCd a b -> m
forall m a b.
Monoid m =>
(a -> m) -> (b -> m) -> ChangeAndCd a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f b -> m
g) [ChangeAndCd a b]
instanceChangesAndCds

instance Bitraversable GenericClassDiagramInstance where
  bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d)
-> GenericClassDiagramInstance a b
-> f (GenericClassDiagramInstance c d)
bitraverse a -> f c
f b -> f d
g ClassDiagramInstance {[b]
[ChangeAndCd a b]
AnyClassDiagram a b
instanceClassDiagram :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
instanceRelationshipNames :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [relationshipName]
instanceChangesAndCds :: forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [ChangeAndCd className relationshipName]
instanceClassDiagram :: AnyClassDiagram a b
instanceRelationshipNames :: [b]
instanceChangesAndCds :: [ChangeAndCd a b]
..} = AnyClassDiagram c d
-> [d] -> [ChangeAndCd c d] -> GenericClassDiagramInstance c d
forall className relationshipName.
AnyClassDiagram className relationshipName
-> [relationshipName]
-> [ChangeAndCd className relationshipName]
-> GenericClassDiagramInstance className relationshipName
ClassDiagramInstance
    (AnyClassDiagram c d
 -> [d] -> [ChangeAndCd c d] -> GenericClassDiagramInstance c d)
-> f (AnyClassDiagram c d)
-> f ([d] -> [ChangeAndCd c d] -> GenericClassDiagramInstance c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f c)
-> (b -> f d) -> AnyClassDiagram a b -> f (AnyClassDiagram c d)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d) -> AnyClassDiagram a b -> f (AnyClassDiagram c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f c
f b -> f d
g AnyClassDiagram a b
instanceClassDiagram
    f ([d] -> [ChangeAndCd c d] -> GenericClassDiagramInstance c d)
-> f [d]
-> f ([ChangeAndCd c d] -> GenericClassDiagramInstance c d)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (b -> f d) -> [b] -> f [d]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse b -> f d
g [b]
instanceRelationshipNames
    f ([ChangeAndCd c d] -> GenericClassDiagramInstance c d)
-> f [ChangeAndCd c d] -> f (GenericClassDiagramInstance c d)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ChangeAndCd a b -> f (ChangeAndCd c d))
-> [ChangeAndCd a b] -> f [ChangeAndCd c d]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((a -> f c) -> (b -> f d) -> ChangeAndCd a b -> f (ChangeAndCd c d)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> ChangeAndCd a b -> f (ChangeAndCd c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f c
f b -> f d
g) [ChangeAndCd a b]
instanceChangesAndCds

type ClassDiagramInstance = GenericClassDiagramInstance String String

renameClassesAndRelationshipsInCdInstance
  :: (MonadThrow m, Ord c, Ord c', Ord r, Ord r')
  => Bimap c c'
  -> Bimap r r'
  -> GenericClassDiagramInstance c r
  -> m (GenericClassDiagramInstance c' r')
renameClassesAndRelationshipsInCdInstance :: forall (m :: * -> *) c c' r r'.
(MonadThrow m, Ord c, Ord c', Ord r, Ord r') =>
Bimap c c'
-> Bimap r r'
-> GenericClassDiagramInstance c r
-> m (GenericClassDiagramInstance c' r')
renameClassesAndRelationshipsInCdInstance
  Bimap c c'
bmClassNames
  Bimap r r'
bmRelationshipNames
  = (c -> m c')
-> (r -> m r')
-> GenericClassDiagramInstance c r
-> m (GenericClassDiagramInstance c' r')
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d)
-> GenericClassDiagramInstance a b
-> f (GenericClassDiagramInstance c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (c -> Bimap c c' -> m c'
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
a -> Bimap a b -> m b
`BM.lookup` Bimap c c'
bmClassNames) (r -> Bimap r r' -> m r'
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
a -> Bimap a b -> m b
`BM.lookup` Bimap r r'
bmRelationshipNames)

{-|
This version deliberately reuses names when changes to class diagrams
have been applied,
i.e. in the resulting class diagram the added relationship is named exactly
as the removed one.
This is especially required for the MatchCdOd task type where the overlap on
resulting ODs is intended.
Beware that this overlap is reflected in the class diagram only,
but NOT in the change itself.
-}
fromInstanceWithNameOverlap
  :: MonadThrow m
  => AlloyInstance
  -> m ClassDiagramInstance
fromInstanceWithNameOverlap :: forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m ClassDiagramInstance
fromInstanceWithNameOverlap AlloyInstance
alloyInstance = do
  ClassDiagramInstance
cdInstance <- AlloyInstance -> m ClassDiagramInstance
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m ClassDiagramInstance
fromInstance AlloyInstance
alloyInstance
  ClassDiagramInstance -> m ClassDiagramInstance
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDiagramInstance -> m ClassDiagramInstance)
-> ClassDiagramInstance -> m ClassDiagramInstance
forall a b. (a -> b) -> a -> b
$ ClassDiagramInstance
cdInstance {
    instanceChangesAndCds :: [ChangeAndCd String String]
instanceChangesAndCds = (ChangeAndCd String String -> ChangeAndCd String String)
-> [ChangeAndCd String String] -> [ChangeAndCd String String]
forall a b. (a -> b) -> [a] -> [b]
map ChangeAndCd String String -> ChangeAndCd String String
forall {relationshipName} {className}.
Eq relationshipName =>
ChangeAndCd className relationshipName
-> ChangeAndCd className relationshipName
deliberatelyNameReplacedEdgesSameInCdOnly
      ([ChangeAndCd String String] -> [ChangeAndCd String String])
-> [ChangeAndCd String String] -> [ChangeAndCd String String]
forall a b. (a -> b) -> a -> b
$ ClassDiagramInstance -> [ChangeAndCd String String]
forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [ChangeAndCd className relationshipName]
instanceChangesAndCds ClassDiagramInstance
cdInstance
    }
  where
    deliberatelyNameReplacedEdgesSameInCdOnly :: ChangeAndCd className relationshipName
-> ChangeAndCd className relationshipName
deliberatelyNameReplacedEdgesSameInCdOnly ChangeAndCd className relationshipName
change =
      case ChangeAndCd className relationshipName
-> Change (AnyRelationship className relationshipName)
forall className relationshipName.
ChangeAndCd className relationshipName
-> Change (AnyRelationship className relationshipName)
relationshipChange ChangeAndCd className relationshipName
change of
        Change {add :: forall a. Change a -> Maybe a
add = Just AnyRelationship className relationshipName
rx, remove :: forall a. Change a -> Maybe a
remove = Just AnyRelationship className relationshipName
ry}
          | Just relationshipName
x <- AnyRelationship className relationshipName
-> Maybe relationshipName
forall className relationshipName.
AnyRelationship className relationshipName
-> Maybe relationshipName
anyRelationshipName AnyRelationship className relationshipName
rx
          , Just relationshipName
y <- AnyRelationship className relationshipName
-> Maybe relationshipName
forall className relationshipName.
AnyRelationship className relationshipName
-> Maybe relationshipName
anyRelationshipName AnyRelationship className relationshipName
ry ->
            let rename :: AnyClassDiagram a relationshipName
-> AnyClassDiagram a relationshipName
rename = (relationshipName -> relationshipName)
-> AnyClassDiagram a relationshipName
-> AnyClassDiagram a relationshipName
forall b c a.
(b -> c) -> AnyClassDiagram a b -> AnyClassDiagram a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\relationshipName
x' -> if relationshipName
x' relationshipName -> relationshipName -> Bool
forall a. Eq a => a -> a -> Bool
== relationshipName
x then relationshipName
y else relationshipName
x')
            in ChangeAndCd className relationshipName
change {
              changeClassDiagram :: AnyClassDiagram className relationshipName
changeClassDiagram = AnyClassDiagram className relationshipName
-> AnyClassDiagram className relationshipName
forall {a}.
AnyClassDiagram a relationshipName
-> AnyClassDiagram a relationshipName
rename (AnyClassDiagram className relationshipName
 -> AnyClassDiagram className relationshipName)
-> AnyClassDiagram className relationshipName
-> AnyClassDiagram className relationshipName
forall a b. (a -> b) -> a -> b
$ ChangeAndCd className relationshipName
-> AnyClassDiagram className relationshipName
forall className relationshipName.
ChangeAndCd className relationshipName
-> AnyClassDiagram className relationshipName
changeClassDiagram ChangeAndCd className relationshipName
change
              }
        Change {} -> ChangeAndCd className relationshipName
change

{-|
Retrieve the instance with predefined class diagram component names.
This only makes sense if a class diagram with names was already provided to
Alloy beforehand.

This is achieved by relying on 'usePredefinedClassDiagramInstanceNames';
be sure to check its restrictions!
-}
fromInstanceWithPredefinedNames
  :: MonadThrow m
  => AlloyInstance
  -> m (GenericClassDiagramInstance String String)
fromInstanceWithPredefinedNames :: forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m ClassDiagramInstance
fromInstanceWithPredefinedNames =
  ClassDiagramInstance -> m ClassDiagramInstance
forall (m :: * -> *).
MonadThrow m =>
ClassDiagramInstance -> m ClassDiagramInstance
usePredefinedClassDiagramInstanceNames (ClassDiagramInstance -> m ClassDiagramInstance)
-> (AlloyInstance -> m ClassDiagramInstance)
-> AlloyInstance
-> m ClassDiagramInstance
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< AlloyInstance -> m ClassDiagramInstance
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m ClassDiagramInstance
fromInstanceWithNameOverlap

{-|
Parses an class diagram instance from Alloy consisting of a base CD,
relationship names and changes with CDs derived from the base CD.
-}
fromInstance
  :: MonadThrow m
  => AlloyInstance
  -> m ClassDiagramInstance
fromInstance :: forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m ClassDiagramInstance
fromInstance AlloyInstance
alloyInstance = do
  [(Object, AnyRelationship String String)]
es <- AlloyInstance -> m [(Object, AnyRelationship String String)]
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m [(Object, AnyRelationship String String)]
instanceToEdges AlloyInstance
alloyInstance
  [Change Object]
cs <- AlloyInstance -> m [Change Object]
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m [Change Object]
instanceToChanges AlloyInstance
alloyInstance
  [String]
namesOfClasses <- AlloyInstance -> String -> m [String]
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> String -> m [String]
instanceToNamesOf AlloyInstance
alloyInstance String
"Class"
  [String]
namesOfNonInheritances <- AlloyInstance -> String -> m [String]
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> String -> m [String]
instanceToNamesOf AlloyInstance
alloyInstance String
"NonInheritance"
  let baseCd :: AnyClassDiagram String String
baseCd = AnyClassDiagram {
        anyClassNames :: [String]
anyClassNames = [String]
namesOfClasses,
        anyRelationships :: [AnyRelationship String String]
anyRelationships =
          [AnyRelationship String String
e | (Object
o, AnyRelationship String String
e) <- [(Object, AnyRelationship String String)]
es, Object
o Object -> [Object] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Change Object -> Maybe Object) -> [Change Object] -> [Object]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Change Object -> Maybe Object
forall a. Change a -> Maybe a
add [Change Object]
cs]
        }
      modifiedCd :: Maybe (AnyRelationship String String)
-> Maybe (AnyRelationship String String)
-> AnyClassDiagram String String
modifiedCd Maybe (AnyRelationship String String)
ma Maybe (AnyRelationship String String)
mr = AnyClassDiagram String String
baseCd {
        anyRelationships :: [AnyRelationship String String]
anyRelationships = Maybe (AnyRelationship String String)
-> [AnyRelationship String String]
forall a. Maybe a -> [a]
maybeToList Maybe (AnyRelationship String String)
ma
          [AnyRelationship String String]
-> [AnyRelationship String String]
-> [AnyRelationship String String]
forall a. [a] -> [a] -> [a]
++ ([AnyRelationship String String]
 -> [AnyRelationship String String])
-> (AnyRelationship String String
    -> [AnyRelationship String String]
    -> [AnyRelationship String String])
-> Maybe (AnyRelationship String String)
-> [AnyRelationship String String]
-> [AnyRelationship String String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [AnyRelationship String String] -> [AnyRelationship String String]
forall a. a -> a
id ((AnyRelationship String String -> Bool)
-> [AnyRelationship String String]
-> [AnyRelationship String String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((AnyRelationship String String -> Bool)
 -> [AnyRelationship String String]
 -> [AnyRelationship String String])
-> (AnyRelationship String String
    -> AnyRelationship String String -> Bool)
-> AnyRelationship String String
-> [AnyRelationship String String]
-> [AnyRelationship String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyRelationship String String
-> AnyRelationship String String -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) Maybe (AnyRelationship String String)
mr (AnyClassDiagram String String -> [AnyRelationship String String]
forall className relationshipName.
AnyClassDiagram className relationshipName
-> [AnyRelationship className relationshipName]
anyRelationships AnyClassDiagram String String
baseCd)
        }
  ClassDiagramInstance -> m ClassDiagramInstance
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassDiagramInstance {
    instanceClassDiagram :: AnyClassDiagram String String
instanceClassDiagram = AnyClassDiagram String String
baseCd,
    instanceRelationshipNames :: [String]
instanceRelationshipNames = [String]
namesOfNonInheritances,
    instanceChangesAndCds :: [ChangeAndCd String String]
instanceChangesAndCds = [
        ChangeAndCd {
          relationshipChange :: Change (AnyRelationship String String)
relationshipChange = Maybe (AnyRelationship String String)
-> Maybe (AnyRelationship String String)
-> Change (AnyRelationship String String)
forall a. Maybe a -> Maybe a -> Change a
Change Maybe (AnyRelationship String String)
a Maybe (AnyRelationship String String)
r,
          changeClassDiagram :: AnyClassDiagram String String
changeClassDiagram = Maybe (AnyRelationship String String)
-> Maybe (AnyRelationship String String)
-> AnyClassDiagram String String
modifiedCd Maybe (AnyRelationship String String)
a Maybe (AnyRelationship String String)
r
          }
      | Change Object
c <- [Change Object]
cs
      , Maybe (AnyRelationship String String)
a <- Maybe Object
-> [(Object, AnyRelationship String String)]
-> [Maybe (AnyRelationship String String)]
forall a b. Eq a => Maybe a -> [(a, b)] -> [Maybe b]
lookupM (Change Object -> Maybe Object
forall a. Change a -> Maybe a
add Change Object
c) [(Object, AnyRelationship String String)]
es
      , Maybe (AnyRelationship String String)
r <- Maybe Object
-> [(Object, AnyRelationship String String)]
-> [Maybe (AnyRelationship String String)]
forall a b. Eq a => Maybe a -> [(a, b)] -> [Maybe b]
lookupM (Change Object -> Maybe Object
forall a. Change a -> Maybe a
remove Change Object
c) [(Object, AnyRelationship String String)]
es
      ]
    }
  where
    lookupM :: Eq a => Maybe a -> [(a, b)] -> [Maybe b]
    lookupM :: forall a b. Eq a => Maybe a -> [(a, b)] -> [Maybe b]
lookupM Maybe a
Nothing  [(a, b)]
_  = [Maybe b
forall a. Maybe a
Nothing]
    lookupM (Just a
k) [(a, b)]
ms = [Maybe b
v | let v :: Maybe b
v = a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
k [(a, b)]
ms, Maybe b -> Bool
forall a. Maybe a -> Bool
isJust Maybe b
v]

instanceToNamesOf
  :: MonadThrow m
  => AlloyInstance
  -> String
  -> m [String]
instanceToNamesOf :: forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> String -> m [String]
instanceToNamesOf AlloyInstance
alloyInstance String
what = do
  AlloySig
x <- Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig (String -> String -> Signature
scoped String
"this" String
what) AlloyInstance
alloyInstance
  (Object -> String) -> [Object] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Object -> String
objectName ([Object] -> [String])
-> (Set Object -> [Object]) -> Set Object -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Object -> [Object]
forall a. Set a -> [a]
S.toList (Set Object -> [String]) -> m (Set Object) -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (String -> Int -> m Object) -> AlloySig -> m (Set Object)
forall (m :: * -> *) a.
(MonadThrow m, Ord a) =>
String -> (String -> Int -> m a) -> AlloySig -> m (Set a)
getSingleAs String
"" (Object -> m Object
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> m Object)
-> (String -> Int -> Object) -> String -> Int -> m Object
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: String -> Int -> Object
Object) AlloySig
x

instanceToChanges
  :: MonadThrow m
  => AlloyInstance
  -> m [Change Object]
instanceToChanges :: forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m [Change Object]
instanceToChanges AlloyInstance
alloyInstance = do
  AlloySig
c'      <- Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig (String -> String -> Signature
scoped String
"this" String
"Change") AlloyInstance
alloyInstance
  [Object]
cs      <- Set Object -> [Object]
forall a. Set a -> [a]
S.toList (Set Object -> [Object]) -> m (Set Object) -> m [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (String -> Int -> m Object) -> AlloySig -> m (Set Object)
forall (m :: * -> *) a.
(MonadThrow m, Ord a) =>
String -> (String -> Int -> m a) -> AlloySig -> m (Set a)
getSingleAs String
"" (Object -> m Object
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> m Object)
-> (String -> Int -> Object) -> String -> Int -> m Object
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: String -> Int -> Object
Object) AlloySig
c'
  Map Object Object
cAdd    <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"add" AlloySig
c'
  Map Object Object
cRemove <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"remove" AlloySig
c'
  [Change Object] -> m [Change Object]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Change Object] -> m [Change Object])
-> [Change Object] -> m [Change Object]
forall a b. (a -> b) -> a -> b
$ (Object -> Change Object) -> [Object] -> [Change Object]
forall a b. (a -> b) -> [a] -> [b]
map (Map Object Object -> Map Object Object -> Object -> Change Object
forall {k} {a}. Ord k => Map k a -> Map k a -> k -> Change a
change Map Object Object
cAdd Map Object Object
cRemove) [Object]
cs
  where
    change :: Map k a -> Map k a -> k -> Change a
change Map k a
cAdd Map k a
cRemove k
c =
      Maybe a -> Maybe a -> Change a
forall a. Maybe a -> Maybe a -> Change a
Change (k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
c Map k a
cAdd) (k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
c Map k a
cRemove)

newtype Relation = Relation {Relation -> String
unRelation :: String}

newtype UnexpectedRelation
  = SingleMemberExpected Relation

instance Show UnexpectedRelation where
  show :: UnexpectedRelation -> String
show (SingleMemberExpected Relation
relation) = String
"SingleMemberExpected: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Relation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Relation -> String
unRelation Relation
relation
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" matches at least one "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"member of its domain to multiple values of the codomain."

instance Exception UnexpectedRelation

getRelation :: MonadThrow m => String -> AlloySig -> m (Map Object Object)
getRelation :: forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
n AlloySig
i = String
-> (String -> Int -> m Object)
-> (String -> Int -> m Object)
-> AlloySig
-> m (Set (Object, Object))
forall (m :: * -> *) a b.
(MonadThrow m, Ord a, Ord b) =>
String
-> (String -> Int -> m a)
-> (String -> Int -> m b)
-> AlloySig
-> m (Set (a, b))
getDoubleAs String
n (Object -> m Object
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> m Object)
-> (String -> Int -> Object) -> String -> Int -> m Object
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: String -> Int -> Object
Object) (Object -> m Object
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> m Object)
-> (String -> Int -> Object) -> String -> Int -> m Object
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: String -> Int -> Object
Object) AlloySig
i
  m (Set (Object, Object))
-> (Set (Object, Object) -> m (Map Object Object))
-> m (Map Object Object)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Set Object -> m Object)
-> Map Object (Set Object) -> m (Map Object Object)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Object a -> m (Map Object b)
mapM Set Object -> m Object
forall {m :: * -> *} {a}. MonadThrow m => Set a -> m a
single (Map Object (Set Object) -> m (Map Object Object))
-> (Set (Object, Object) -> Map Object (Set Object))
-> Set (Object, Object)
-> m (Map Object Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Object, Object) -> Map Object (Set Object)
forall a b. (Ord a, Ord b) => Set (a, b) -> Map a (Set b)
toMap
  where
    single :: Set a -> m a
single Set a
x
      | Set a -> Int
forall a. Set a -> Int
S.size Set a
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Set a -> a
forall a. Set a -> a
S.findMin Set a
x
      | Bool
otherwise     = UnexpectedRelation -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnexpectedRelation -> m a) -> UnexpectedRelation -> m a
forall a b. (a -> b) -> a -> b
$ Relation -> UnexpectedRelation
SingleMemberExpected (Relation -> UnexpectedRelation) -> Relation -> UnexpectedRelation
forall a b. (a -> b) -> a -> b
$ String -> Relation
Relation String
n

{-|
Parses all Relationships.
-}
instanceToEdges
  :: MonadThrow m
  => AlloyInstance
  -> m [(Object, AnyRelationship String String)]
instanceToEdges :: forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m [(Object, AnyRelationship String String)]
instanceToEdges AlloyInstance
inst = do
  AlloySig
r'         <- Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig (String -> String -> Signature
scoped String
"this" String
"Relationship") AlloyInstance
inst
  Map Object Object
rFrom      <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"from" AlloySig
r'
  Map Object Object
rTo        <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"to" AlloySig
r'
  AlloySig
limited    <- Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig (String -> String -> Signature
scoped String
"this" String
"Limited") AlloyInstance
inst
  Map Object Object
aFromLower <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"fromLower" AlloySig
limited
  Map Object Object
aFromUpper <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"fromUpper" AlloySig
limited
  Map Object Object
aToLower   <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"toLower" AlloySig
limited
  Map Object Object
aToUpper   <- String -> AlloySig -> m (Map Object Object)
forall (m :: * -> *).
MonadThrow m =>
String -> AlloySig -> m (Map Object Object)
getRelation String
"toUpper" AlloySig
limited
  AlloyInstance
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> m [(Object, AnyRelationship String String)]
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> m [(Object, AnyRelationship String String)]
instanceToEdges' AlloyInstance
inst Map Object Object
rFrom Map Object Object
rTo Map Object Object
aFromLower Map Object Object
aFromUpper Map Object Object
aToLower Map Object Object
aToUpper

instanceToEdges'
  :: MonadThrow m
  => AlloyInstance
  -> Map Object Object
  -> Map Object Object
  -> Map Object Object
  -> Map Object Object
  -> Map Object Object
  -> Map Object Object
  -> m [(Object, AnyRelationship String String)]
instanceToEdges' :: forall (m :: * -> *).
MonadThrow m =>
AlloyInstance
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> Map Object Object
-> m [(Object, AnyRelationship String String)]
instanceToEdges' AlloyInstance
alloyInstance Map Object Object
rFrom Map Object Object
rTo Map Object Object
aFromLower Map Object Object
aFromUpper Map Object Object
aToLower Map Object Object
aToUpper = do
  [(Object, Relationship String String)]
inheritances <- m [(Object, Relationship String String)]
forall {relationshipName}.
m [(Object, Relationship String relationshipName)]
getInheritances
  [(Object, Relationship String String)]
compositions <- (String
 -> LimitedLinking String
 -> LimitedLinking String
 -> Relationship String String)
-> String -> m [(Object, Relationship String String)]
forall {a}.
(String -> LimitedLinking String -> LimitedLinking String -> a)
-> String -> m [(Object, a)]
getRelationships String
-> LimitedLinking String
-> LimitedLinking String
-> Relationship String String
forall {relationshipName} {className}.
relationshipName
-> LimitedLinking className
-> LimitedLinking className
-> Relationship className relationshipName
toComposition String
"Composition"
  [(Object, Relationship String String)]
aggregations <- (String
 -> LimitedLinking String
 -> LimitedLinking String
 -> Relationship String String)
-> String -> m [(Object, Relationship String String)]
forall {a}.
(String -> LimitedLinking String -> LimitedLinking String -> a)
-> String -> m [(Object, a)]
getRelationships String
-> LimitedLinking String
-> LimitedLinking String
-> Relationship String String
forall {relationshipName} {className}.
relationshipName
-> LimitedLinking className
-> LimitedLinking className
-> Relationship className relationshipName
toAggregation String
"Aggregation"
  [(Object, Relationship String String)]
associations <- (String
 -> LimitedLinking String
 -> LimitedLinking String
 -> Relationship String String)
-> String -> m [(Object, Relationship String String)]
forall {a}.
(String -> LimitedLinking String -> LimitedLinking String -> a)
-> String -> m [(Object, a)]
getRelationships String
-> LimitedLinking String
-> LimitedLinking String
-> Relationship String String
forall {relationshipName} {className}.
relationshipName
-> LimitedLinking className
-> LimitedLinking className
-> Relationship className relationshipName
toAssociation String
"Association"
  [(Object, AnyRelationship String String)]
invalidInheritances <- ((Object, InvalidRelationship String String)
 -> (Object, AnyRelationship String String))
-> [(Object, InvalidRelationship String String)]
-> [(Object, AnyRelationship String String)]
forall a b. (a -> b) -> [a] -> [b]
map ((InvalidRelationship String String
 -> AnyRelationship String String)
-> (Object, InvalidRelationship String String)
-> (Object, AnyRelationship String String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second InvalidRelationship String String -> AnyRelationship String String
forall a b. a -> Either a b
Left)
    ([(Object, InvalidRelationship String String)]
 -> [(Object, AnyRelationship String String)])
-> m [(Object, InvalidRelationship String String)]
-> m [(Object, AnyRelationship String String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
 -> LimitedLinking String
 -> LimitedLinking String
 -> InvalidRelationship String String)
-> String -> m [(Object, InvalidRelationship String String)]
forall {a}.
(String -> LimitedLinking String -> LimitedLinking String -> a)
-> String -> m [(Object, a)]
getRelationships String
-> LimitedLinking String
-> LimitedLinking String
-> InvalidRelationship String String
forall {p} {className} {relationshipName}.
p
-> LimitedLinking className
-> LimitedLinking className
-> InvalidRelationship className relationshipName
toInvalidInheritance String
"InvalidInheritance"
  [(Object, AnyRelationship String String)]
-> m [(Object, AnyRelationship String String)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Object, AnyRelationship String String)]
 -> m [(Object, AnyRelationship String String)])
-> ([(Object, Relationship String String)]
    -> [(Object, AnyRelationship String String)])
-> [(Object, Relationship String String)]
-> m [(Object, AnyRelationship String String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Object, AnyRelationship String String)]
-> [(Object, AnyRelationship String String)]
-> [(Object, AnyRelationship String String)]
forall a. [a] -> [a] -> [a]
++ [(Object, AnyRelationship String String)]
invalidInheritances) ([(Object, AnyRelationship String String)]
 -> [(Object, AnyRelationship String String)])
-> ([(Object, Relationship String String)]
    -> [(Object, AnyRelationship String String)])
-> [(Object, Relationship String String)]
-> [(Object, AnyRelationship String String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Object, Relationship String String)
 -> (Object, AnyRelationship String String))
-> [(Object, Relationship String String)]
-> [(Object, AnyRelationship String String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Relationship String String -> AnyRelationship String String)
-> (Object, Relationship String String)
-> (Object, AnyRelationship String String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Relationship String String -> AnyRelationship String String
forall a b. b -> Either a b
Right)
    ([(Object, Relationship String String)]
 -> m [(Object, AnyRelationship String String)])
-> [(Object, Relationship String String)]
-> m [(Object, AnyRelationship String String)]
forall a b. (a -> b) -> a -> b
$ [(Object, Relationship String String)]
inheritances [(Object, Relationship String String)]
-> [(Object, Relationship String String)]
-> [(Object, Relationship String String)]
forall a. [a] -> [a] -> [a]
++ [(Object, Relationship String String)]
compositions [(Object, Relationship String String)]
-> [(Object, Relationship String String)]
-> [(Object, Relationship String String)]
forall a. [a] -> [a] -> [a]
++ [(Object, Relationship String String)]
aggregations [(Object, Relationship String String)]
-> [(Object, Relationship String String)]
-> [(Object, Relationship String String)]
forall a. [a] -> [a] -> [a]
++ [(Object, Relationship String String)]
associations
  where
    getInheritances :: m [(Object, Relationship String relationshipName)]
getInheritances = do
      AlloySig
inheritance' <- Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig (String -> String -> Signature
scoped String
"this" String
"ValidInheritance") AlloyInstance
alloyInstance
      [Object]
inheritances <-
        Set Object -> [Object]
forall a. Set a -> [a]
S.toList (Set Object -> [Object]) -> m (Set Object) -> m [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (String -> Int -> m Object) -> AlloySig -> m (Set Object)
forall (m :: * -> *) a.
(MonadThrow m, Ord a) =>
String -> (String -> Int -> m a) -> AlloySig -> m (Set a)
getSingleAs String
"" (Object -> m Object
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> m Object)
-> (String -> Int -> Object) -> String -> Int -> m Object
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: String -> Int -> Object
Object) AlloySig
inheritance'
      [Object]
-> (Object -> m (Object, Relationship String relationshipName))
-> m [(Object, Relationship String relationshipName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Object]
inheritances ((Object -> m (Object, Relationship String relationshipName))
 -> m [(Object, Relationship String relationshipName)])
-> (Object -> m (Object, Relationship String relationshipName))
-> m [(Object, Relationship String relationshipName)]
forall a b. (a -> b) -> a -> b
$ \Object
inheritance -> (Object
inheritance,) (Relationship String relationshipName
 -> (Object, Relationship String relationshipName))
-> m (Relationship String relationshipName)
-> m (Object, Relationship String relationshipName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        String
from <- Object -> Map Object Object -> m String
forall (m :: * -> *) k.
(MonadThrow m, Ord k) =>
k -> Map k Object -> m String
lookupObj Object
inheritance Map Object Object
rFrom
        String
to   <- Object -> Map Object Object -> m String
forall (m :: * -> *) k.
(MonadThrow m, Ord k) =>
k -> Map k Object -> m String
lookupObj Object
inheritance Map Object Object
rTo
        Relationship String relationshipName
-> m (Relationship String relationshipName)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Inheritance {
          subClass :: String
subClass = String
from,
          superClass :: String
superClass = String
to
          }
    getRelationships :: (String -> LimitedLinking String -> LimitedLinking String -> a)
-> String -> m [(Object, a)]
getRelationships String -> LimitedLinking String -> LimitedLinking String -> a
f String
relationshipKind = do
      AlloySig
relationship' <- Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig (String -> String -> Signature
scoped String
"this" String
relationshipKind) AlloyInstance
alloyInstance
      [Object]
relationships' <-
        Set Object -> [Object]
forall a. Set a -> [a]
S.toList (Set Object -> [Object]) -> m (Set Object) -> m [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (String -> Int -> m Object) -> AlloySig -> m (Set Object)
forall (m :: * -> *) a.
(MonadThrow m, Ord a) =>
String -> (String -> Int -> m a) -> AlloySig -> m (Set a)
getSingleAs String
"" (Object -> m Object
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> m Object)
-> (String -> Int -> Object) -> String -> Int -> m Object
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: String -> Int -> Object
Object) AlloySig
relationship'
      [Object] -> (Object -> m (Object, a)) -> m [(Object, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Object]
relationships' ((Object -> m (Object, a)) -> m [(Object, a)])
-> (Object -> m (Object, a)) -> m [(Object, a)]
forall a b. (a -> b) -> a -> b
$ \Object
relationship -> (Object
relationship,) (a -> (Object, a)) -> m a -> m (Object, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        let name :: String
name = Object -> String
objectName Object
relationship
        LimitedLinking String
from <- Object -> m (LimitedLinking String)
getFrom Object
relationship
        LimitedLinking String
to   <- Object -> m (LimitedLinking String)
getTo Object
relationship
        a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ String -> LimitedLinking String -> LimitedLinking String -> a
f String
name LimitedLinking String
from LimitedLinking String
to
    getFrom :: Object -> m (LimitedLinking String)
getFrom = Map Object Object
-> Map Object Object
-> Map Object Object
-> Object
-> m (LimitedLinking String)
forall (m :: * -> *) k.
(MonadThrow m, Ord k) =>
Map k Object
-> Map k Object -> Map k Object -> k -> m (LimitedLinking String)
getLinking Map Object Object
rFrom Map Object Object
aFromLower Map Object Object
aFromUpper
    getTo :: Object -> m (LimitedLinking String)
getTo = Map Object Object
-> Map Object Object
-> Map Object Object
-> Object
-> m (LimitedLinking String)
forall (m :: * -> *) k.
(MonadThrow m, Ord k) =>
Map k Object
-> Map k Object -> Map k Object -> k -> m (LimitedLinking String)
getLinking Map Object Object
rTo Map Object Object
aToLower Map Object Object
aToUpper
    toAssociation :: relationshipName
-> LimitedLinking className
-> LimitedLinking className
-> Relationship className relationshipName
toAssociation relationshipName
name LimitedLinking className
from LimitedLinking className
to = Association {
      associationName :: relationshipName
associationName = relationshipName
name,
      associationFrom :: LimitedLinking className
associationFrom = LimitedLinking className
from,
      associationTo :: LimitedLinking className
associationTo = LimitedLinking className
to
      }
    toAggregation :: relationshipName
-> LimitedLinking className
-> LimitedLinking className
-> Relationship className relationshipName
toAggregation relationshipName
name LimitedLinking className
from LimitedLinking className
to = Aggregation {
      aggregationName :: relationshipName
aggregationName = relationshipName
name,
      aggregationPart :: LimitedLinking className
aggregationPart = LimitedLinking className
from,
      aggregationWhole :: LimitedLinking className
aggregationWhole = LimitedLinking className
to
      }
    toComposition :: relationshipName
-> LimitedLinking className
-> LimitedLinking className
-> Relationship className relationshipName
toComposition relationshipName
name LimitedLinking className
from LimitedLinking className
to = Composition {
      compositionName :: relationshipName
compositionName = relationshipName
name,
      compositionPart :: LimitedLinking className
compositionPart = LimitedLinking className
from,
      compositionWhole :: LimitedLinking className
compositionWhole = LimitedLinking className
to
      }
    toInvalidInheritance :: p
-> LimitedLinking className
-> LimitedLinking className
-> InvalidRelationship className relationshipName
toInvalidInheritance p
_ LimitedLinking className
from LimitedLinking className
to = InvalidInheritance {
      invalidSubClass :: LimitedLinking className
invalidSubClass = LimitedLinking className
from,
      invalidSuperClass :: LimitedLinking className
invalidSuperClass = LimitedLinking className
to
      }

data ReadObjectDiagramFromAlloyException
  = MissingObject
  | MissingLimit
  | UnknownLimit !String
  deriving Int -> ReadObjectDiagramFromAlloyException -> String -> String
[ReadObjectDiagramFromAlloyException] -> String -> String
ReadObjectDiagramFromAlloyException -> String
(Int -> ReadObjectDiagramFromAlloyException -> String -> String)
-> (ReadObjectDiagramFromAlloyException -> String)
-> ([ReadObjectDiagramFromAlloyException] -> String -> String)
-> Show ReadObjectDiagramFromAlloyException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ReadObjectDiagramFromAlloyException -> String -> String
showsPrec :: Int -> ReadObjectDiagramFromAlloyException -> String -> String
$cshow :: ReadObjectDiagramFromAlloyException -> String
show :: ReadObjectDiagramFromAlloyException -> String
$cshowList :: [ReadObjectDiagramFromAlloyException] -> String -> String
showList :: [ReadObjectDiagramFromAlloyException] -> String -> String
Show

instance Exception ReadObjectDiagramFromAlloyException

lookupObj :: (MonadThrow m, Ord k) => k -> Map k Object -> m String
lookupObj :: forall (m :: * -> *) k.
(MonadThrow m, Ord k) =>
k -> Map k Object -> m String
lookupObj k
k Map k Object
m = case k -> Map k Object -> Maybe Object
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k Object
m of
  Maybe Object
Nothing -> ReadObjectDiagramFromAlloyException -> m String
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ReadObjectDiagramFromAlloyException
MissingObject
  Just Object
v  -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Object -> String
objectName Object
v

getLinking
  :: (MonadThrow m, Ord k)
  => Map k Object
  -> Map k Object
  -> Map k Object
  -> k
  -> m (LimitedLinking String)
getLinking :: forall (m :: * -> *) k.
(MonadThrow m, Ord k) =>
Map k Object
-> Map k Object -> Map k Object -> k -> m (LimitedLinking String)
getLinking Map k Object
link Map k Object
low Map k Object
high k
x = do
  String
link' <- k -> Map k Object -> m String
forall (m :: * -> *) k.
(MonadThrow m, Ord k) =>
k -> Map k Object -> m String
lookupObj k
x Map k Object
link
  Maybe Int
low'  <- k -> Map k Object -> m (Maybe Int)
forall {k} {m :: * -> *} {a}.
(Ord k, MonadThrow m, Num a) =>
k -> Map k Object -> m (Maybe a)
lookupLimit k
x Map k Object
low
  Maybe Int
high' <- k -> Map k Object -> m (Maybe Int)
forall {k} {m :: * -> *} {a}.
(Ord k, MonadThrow m, Num a) =>
k -> Map k Object -> m (Maybe a)
lookupLimit k
x Map k Object
high
  LimitedLinking String -> m (LimitedLinking String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LimitedLinking {
    linking :: String
linking = String
link',
    limits :: (Int, Maybe Int)
limits = (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (-Int
1) Maybe Int
low', Maybe Int
high')
    }
  where
    lookupLimit :: k -> Map k Object -> m (Maybe a)
lookupLimit k
k Map k Object
m = case k -> Map k Object -> Maybe Object
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k Object
m of
      Maybe Object
Nothing -> ReadObjectDiagramFromAlloyException -> m (Maybe a)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ReadObjectDiagramFromAlloyException
MissingLimit
      Just Object
o -> case Object -> String
oName Object
o of
        String
"Star" -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        String
"Zero" -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
0
        String
"One"  -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
1
        String
"Two"  -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
2
        String
l      -> ReadObjectDiagramFromAlloyException -> m (Maybe a)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ReadObjectDiagramFromAlloyException -> m (Maybe a))
-> ReadObjectDiagramFromAlloyException -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ String -> ReadObjectDiagramFromAlloyException
UnknownLimit String
l

{-|
Define fresh names for each class diagram component.
Capital letters beginning from 'A' are used for class names.
Small letters beginning from 'z' backwards are used for relationship names.
-}
nameClassDiagramInstance
  :: (MonadThrow m, Ord className, Ord relationshipName)
  => GenericClassDiagramInstance className relationshipName
  -> m (GenericClassDiagramInstance String String)
nameClassDiagramInstance :: forall (m :: * -> *) className relationshipName.
(MonadThrow m, Ord className, Ord relationshipName) =>
GenericClassDiagramInstance className relationshipName
-> m ClassDiagramInstance
nameClassDiagramInstance GenericClassDiagramInstance className relationshipName
cdInstance =
  let cd :: AnyClassDiagram className relationshipName
cd = GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
instanceClassDiagram GenericClassDiagramInstance className relationshipName
cdInstance
      cs :: [className]
cs = AnyClassDiagram className relationshipName -> [className]
forall className relationshipName.
AnyClassDiagram className relationshipName -> [className]
anyClassNames AnyClassDiagram className relationshipName
cd
      es :: [relationshipName]
es = GenericClassDiagramInstance className relationshipName
-> [relationshipName]
forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [relationshipName]
instanceRelationshipNames GenericClassDiagramInstance className relationshipName
cdInstance
      bimapEdges :: Bimap relationshipName String
bimapEdges = [(relationshipName, String)] -> Bimap relationshipName String
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList ([(relationshipName, String)] -> Bimap relationshipName String)
-> [(relationshipName, String)] -> Bimap relationshipName String
forall a b. (a -> b) -> a -> b
$ [relationshipName] -> [String] -> [(relationshipName, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [relationshipName]
es ([String] -> [(relationshipName, String)])
-> [String] -> [(relationshipName, String)]
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) [Char
'z', Char
'y' ..]
      bimapClasses :: Bimap className String
bimapClasses = [(className, String)] -> Bimap className String
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList ([(className, String)] -> Bimap className String)
-> [(className, String)] -> Bimap className String
forall a b. (a -> b) -> a -> b
$ [className] -> [String] -> [(className, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [className]
cs ([String] -> [(className, String)])
-> [String] -> [(className, String)]
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) [Char
'A' ..]
  in Bimap className String
-> Bimap relationshipName String
-> GenericClassDiagramInstance className relationshipName
-> m ClassDiagramInstance
forall (m :: * -> *) c c' r r'.
(MonadThrow m, Ord c, Ord c', Ord r, Ord r') =>
Bimap c c'
-> Bimap r r'
-> GenericClassDiagramInstance c r
-> m (GenericClassDiagramInstance c' r')
renameClassesAndRelationshipsInCdInstance
    Bimap className String
bimapClasses
    Bimap relationshipName String
bimapEdges
    GenericClassDiagramInstance className relationshipName
cdInstance

{-|
Use predefined class diagram component names.
This only makes sense if a class diagram with names was already provided to
Alloy beforehand.

All names are gained by stripping everything after the dollar sign.
Attention! This is unsafe if new class diagram components are introduced,
e.g. as part of `add`.
-}
usePredefinedClassDiagramInstanceNames
  :: MonadThrow m
  => GenericClassDiagramInstance String String
  -> m (GenericClassDiagramInstance String String)
usePredefinedClassDiagramInstanceNames :: forall (m :: * -> *).
MonadThrow m =>
ClassDiagramInstance -> m ClassDiagramInstance
usePredefinedClassDiagramInstanceNames ClassDiagramInstance
cdInstance =
  let cd :: AnyClassDiagram String String
cd = ClassDiagramInstance -> AnyClassDiagram String String
forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
instanceClassDiagram ClassDiagramInstance
cdInstance
      cs :: [String]
cs = AnyClassDiagram String String -> [String]
forall className relationshipName.
AnyClassDiagram className relationshipName -> [className]
anyClassNames AnyClassDiagram String String
cd
      es :: [String]
es = ClassDiagramInstance -> [String]
forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> [relationshipName]
instanceRelationshipNames ClassDiagramInstance
cdInstance
      prefixOnly :: String -> String
prefixOnly = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'$')
      bimapEdges :: Bimap String String
bimapEdges = [(String, String)] -> Bimap String String
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList ([(String, String)] -> Bimap String String)
-> [(String, String)] -> Bimap String String
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
es ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
prefixOnly [String]
es
      bimapClasses :: Bimap String String
bimapClasses = [(String, String)] -> Bimap String String
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
BM.fromList ([(String, String)] -> Bimap String String)
-> [(String, String)] -> Bimap String String
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
cs ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
prefixOnly [String]
cs
  in Bimap String String
-> Bimap String String
-> ClassDiagramInstance
-> m ClassDiagramInstance
forall (m :: * -> *) c c' r r'.
(MonadThrow m, Ord c, Ord c', Ord r, Ord r') =>
Bimap c c'
-> Bimap r r'
-> GenericClassDiagramInstance c r
-> m (GenericClassDiagramInstance c' r')
renameClassesAndRelationshipsInCdInstance
    Bimap String String
bimapClasses
    Bimap String String
bimapEdges
    ClassDiagramInstance
cdInstance