module Modelling.CdOd.Generate (
  generateCds,
  instanceToAnyCd,
  instanceToCd,
  ) where

import qualified Data.Bimap                       as BM (
  fromList,
  )

import Capabilities.Alloy               (MonadAlloy, getInstances)
import Modelling.CdOd.CdAndChanges.Instance (
  GenericClassDiagramInstance (..),
  fromInstance,
  )
import Modelling.CdOd.CdAndChanges.Transform (
  transformNoChanges,
  )
import Modelling.CdOd.Types (
  AnyCd,
  AnyClassDiagram (..),
  Cd,
  ClassConfig (..),
  RelationshipProperties,
  anyClassNames,
  anyRelationshipName,
  renameClassesAndRelationships,
  toValidCd,
  )

import Control.Monad.Catch              (MonadThrow)
import Control.Monad.Random             (MonadRandom)
import Data.List (singleton)
import Data.Maybe                       (mapMaybe)
import Language.Alloy.Call              (AlloyInstance)
import System.Random.Shuffle            (shuffleM)

generateCds
  :: (MonadAlloy m, MonadRandom m)
  => Maybe Bool
  -> ClassConfig
  -> RelationshipProperties
  -> Maybe Integer
  -> Maybe Int
  -> m [AlloyInstance]
generateCds :: forall (m :: * -> *).
(MonadAlloy m, MonadRandom m) =>
Maybe Bool
-> ClassConfig
-> RelationshipProperties
-> Maybe Integer
-> Maybe Int
-> m [AlloyInstance]
generateCds Maybe Bool
withNonTrivialInheritance ClassConfig
config RelationshipProperties
props Maybe Integer
maxInstances Maybe Int
to = do
  let alloyCode :: String
alloyCode = ClassConfig -> RelationshipProperties -> Maybe Bool -> String
transformNoChanges ClassConfig
config RelationshipProperties
props Maybe Bool
withNonTrivialInheritance
  [AlloyInstance]
alloyInstances <- Maybe Integer -> Maybe Int -> String -> m [AlloyInstance]
forall (m :: * -> *).
MonadAlloy m =>
Maybe Integer -> Maybe Int -> String -> m [AlloyInstance]
getInstances Maybe Integer
maxInstances Maybe Int
to String
alloyCode
  [AlloyInstance] -> m [AlloyInstance]
forall (m :: * -> *) a. MonadRandom m => [a] -> m [a]
shuffleM [AlloyInstance]
alloyInstances

instanceToAnyCd :: MonadThrow m => AlloyInstance -> m AnyCd
instanceToAnyCd :: forall (m :: * -> *). MonadThrow m => AlloyInstance -> m AnyCd
instanceToAnyCd AlloyInstance
alloyInstance = do
  AnyCd
cd <- GenericClassDiagramInstance String String -> AnyCd
forall className relationshipName.
GenericClassDiagramInstance className relationshipName
-> AnyClassDiagram className relationshipName
instanceClassDiagram (GenericClassDiagramInstance String String -> AnyCd)
-> m (GenericClassDiagramInstance String String) -> m AnyCd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AlloyInstance -> m (GenericClassDiagramInstance String String)
forall (m :: * -> *).
MonadThrow m =>
AlloyInstance -> m (GenericClassDiagramInstance String String)
fromInstance AlloyInstance
alloyInstance
  let classRenamingMap :: Bimap String String
classRenamingMap = [(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 (AnyCd -> [String]
forall className relationshipName.
AnyClassDiagram className relationshipName -> [className]
anyClassNames AnyCd
cd) ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
forall a. a -> [a]
singleton [Char
'A'..]
      relationshipNames :: [String]
relationshipNames = (AnyRelationship String String -> Maybe String)
-> [AnyRelationship String String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AnyRelationship String String -> Maybe String
forall className relationshipName.
AnyRelationship className relationshipName
-> Maybe relationshipName
anyRelationshipName ([AnyRelationship String String] -> [String])
-> [AnyRelationship String String] -> [String]
forall a b. (a -> b) -> a -> b
$ AnyCd -> [AnyRelationship String String]
forall className relationshipName.
AnyClassDiagram className relationshipName
-> [AnyRelationship className relationshipName]
anyRelationships AnyCd
cd
      relationshipRenamingMap :: Bimap String String
relationshipRenamingMap =
        [(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]
relationshipNames ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
forall a. a -> [a]
singleton [Char
'z', Char
'y' ..]
  Bimap String String -> Bimap String String -> AnyCd -> m AnyCd
forall (f :: * -> * -> *) (m :: * -> *) c c' r r'.
(Bitraversable f, MonadThrow m, Ord c, Ord c', Ord r, Ord r') =>
Bimap c c' -> Bimap r r' -> f c r -> m (f c' r')
renameClassesAndRelationships Bimap String String
classRenamingMap Bimap String String
relationshipRenamingMap AnyCd
cd

instanceToCd :: MonadThrow m => AlloyInstance -> m Cd
instanceToCd :: forall (m :: * -> *). MonadThrow m => AlloyInstance -> m Cd
instanceToCd AlloyInstance
alloyInstance = AlloyInstance -> m AnyCd
forall (m :: * -> *). MonadThrow m => AlloyInstance -> m AnyCd
instanceToAnyCd AlloyInstance
alloyInstance m AnyCd -> (AnyCd -> m Cd) -> m Cd
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AnyCd -> m Cd
forall className (m :: * -> *) relationshipName.
(Eq className, MonadThrow m, Show className, Show relationshipName,
 Typeable className, Typeable relationshipName) =>
AnyClassDiagram className relationshipName
-> m (ClassDiagram className relationshipName)
toValidCd