{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wwarn=orphans #-}
module Modelling.CdOd.Auxiliary.Util (
  alloyInstanceToOd,
  emptyArr,
  filterFirst,
  oneAndOther,
  redColor,
  underlinedLabel,
  ) where

import qualified Data.Set                         as S

import Modelling.Auxiliary.Common       (lowerFirst)
import Modelling.CdOd.Types (
  DefaultedLimitedLinking (..),
  Link (..),
  Object (..),
  ObjectDiagram (..),
  Od,
  )

import Language.Alloy.Call              as Alloy (
  AlloyInstance,
  getSingleAs,
  getDoubleAs,
  lookupSig,
  scoped,
  )
import Language.Alloy.Exceptions        (AlloyLookupFailed (..))

import Control.Monad.Catch              (MonadCatch (catch), MonadThrow (throwM))
import Data.GraphViz                    (X11Color (..))
import Data.GraphViz.Attributes.Complete (
  ArrowShape (..),
  ArrowType (..),
  Attribute (..),
  Label (HtmlLabel),
  openMod,
  toWColor,
  )
import Data.GraphViz.Attributes.HTML    as Html
  (Label, Format (..), Label (Text), TextItem (..))
import Data.List.Extra                  (nubOrd)
import Data.Text.Lazy                   (pack)
import Control.Monad.Trans.Random       (RandT, liftCatch)

filterFirst :: Eq a => a -> [a] -> [a]
filterFirst :: forall a. Eq a => a -> [a] -> [a]
filterFirst a
_ []     = []
filterFirst a
x (a
y:[a]
ys) = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then [a]
ys else a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
filterFirst a
x [a]
ys

underlinedLabel :: String -> Attribute
underlinedLabel :: String -> Attribute
underlinedLabel String
s = Label -> Attribute
Label (Label -> Label
HtmlLabel Label
label)
  where
    label :: Html.Label
    label :: Label
label = Text -> Label
Text [Format -> Text -> TextItem
Format Format
Underline [Text -> TextItem
Str (String -> Text
pack String
s)]]

emptyArr :: ArrowType
emptyArr :: ArrowType
emptyArr = [(ArrowModifier, ArrowShape)] -> ArrowType
AType [(ArrowModifier
openMod, ArrowShape
Normal)]

redColor :: Attribute
redColor :: Attribute
redColor = ColorList -> Attribute
Color [X11Color -> WeightedColor
forall nc. NamedColor nc => nc -> WeightedColor
toWColor X11Color
Red]

instance {-# OVERLAPPABLE #-} MonadCatch m => MonadCatch (RandT g m) where
  catch :: forall e a.
Exception e =>
RandT g m a -> (e -> RandT g m a) -> RandT g m a
catch = Catch e m (a, g) -> Catch e (RandT g m) a
forall e (m :: * -> *) a g.
Catch e m (a, g) -> Catch e (RandT g m) a
liftCatch Catch e m (a, g)
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch

{-|
Parses the Alloy object diagram instance.
-}
alloyInstanceToOd
  :: MonadCatch m
  => Maybe [String]
  -- ^ the super class set of all potential objects
  -- (all possible class names is also possible)
  --
  -- Only required for Alloy instances that were generated with
  -- @LinguisticReuse@ set to @ExtendsAnd FieldPlacement@,
  -- otherwise 'Nothing'
  -> [String]
  -- ^ all possible link names
  -> AlloyInstance
  -- ^ the alloy instance to parse
  -> m Od
alloyInstanceToOd :: forall (m :: * -> *).
MonadCatch m =>
Maybe [String] -> [String] -> AlloyInstance -> m Od
alloyInstanceToOd Maybe [String]
maybeAllClassNames [String]
allLinkNames AlloyInstance
i = case Maybe [String]
maybeAllClassNames of
  Maybe [String]
Nothing -> do
    AlloySig
os <- Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig (String -> String -> Signature
scoped String
"this" String
"Object") AlloyInstance
i
    [Object String String]
objects <- Set (Object String String) -> [Object String String]
forall a. Set a -> [a]
S.toList (Set (Object String String) -> [Object String String])
-> m (Set (Object String String)) -> m [Object String String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> (String -> Int -> m (Object String String))
-> AlloySig
-> m (Set (Object String String))
forall (m :: * -> *) a.
(MonadThrow m, Ord a) =>
String -> (String -> Int -> m a) -> AlloySig -> m (Set a)
getSingleAs String
"" String -> Int -> m (Object String String)
forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> m (Object String String)
toObject AlloySig
os
    [Link String String]
links <- [[Link String String]] -> [Link String String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Link String String]] -> [Link String String])
-> m [[Link String String]] -> m [Link String String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m [Link String String])
-> [String] -> m [[Link String String]]
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) -> [a] -> m [b]
mapM (AlloySig -> String -> m [Link String String]
forall {f :: * -> *}.
MonadThrow f =>
AlloySig -> String -> f [Link String String]
getLink AlloySig
os) ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
allLinkNames)
    Od -> m Od
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ObjectDiagram {[Link String String]
[Object String String]
objects :: [Object String String]
links :: [Link String String]
objects :: [Object String String]
links :: [Link String String]
..}
  Just [String]
allClassNames -> do
    [AlloySig]
os <- (String -> m AlloySig) -> [String] -> m [AlloySig]
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) -> [a] -> m [b]
mapM ((Signature -> AlloyInstance -> m AlloySig)
-> AlloyInstance -> Signature -> m AlloySig
forall a b c. (a -> b -> c) -> b -> a -> c
flip Signature -> AlloyInstance -> m AlloySig
forall (m :: * -> *).
MonadThrow m =>
Signature -> AlloyInstance -> m AlloySig
lookupSig AlloyInstance
i (Signature -> m AlloySig)
-> (String -> Signature) -> String -> m AlloySig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Signature
scoped String
"this") ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
allClassNames)
    [Object String String]
objects <- Set (Object String String) -> [Object String String]
forall a. Set a -> [a]
S.toList (Set (Object String String) -> [Object String String])
-> ([Set (Object String String)] -> Set (Object String String))
-> [Set (Object String String)]
-> [Object String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set (Object String String)] -> Set (Object String String)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set (Object String String)] -> [Object String String])
-> m [Set (Object String String)] -> m [Object String String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AlloySig -> m (Set (Object String String)))
-> [AlloySig] -> m [Set (Object String String)]
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) -> [a] -> m [b]
mapM (String
-> (String -> Int -> m (Object String String))
-> AlloySig
-> m (Set (Object String String))
forall (m :: * -> *) a.
(MonadThrow m, Ord a) =>
String -> (String -> Int -> m a) -> AlloySig -> m (Set a)
getSingleAs String
"" String -> Int -> m (Object String String)
forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> m (Object String String)
toObject) [AlloySig]
os
    [Link String String]
links <- [[Link String String]] -> [Link String String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Link String String]] -> [Link String String])
-> m [[Link String String]] -> m [Link String String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m [Link String String])
-> [String] -> m [[Link String String]]
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) -> [a] -> m [b]
mapM ([AlloySig] -> String -> m [Link String String]
forall {f :: * -> *}.
Traversable f =>
f AlloySig -> String -> m [Link String String]
getLinks [AlloySig]
os) ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
allLinkNames)
    Od -> m Od
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ObjectDiagram {[Link String String]
[Object String String]
objects :: [Object String String]
links :: [Link String String]
objects :: [Object String String]
links :: [Link String String]
..}
  where
    getLink :: AlloySig -> String -> f [Link String String]
getLink AlloySig
os String
l = ((String, String) -> Link String String)
-> [(String, String)] -> [Link String String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> (String, String) -> Link String String
forall {linkLabel} {objectName}.
linkLabel -> (objectName, objectName) -> Link objectName linkLabel
toLink String
l) ([(String, String)] -> [Link String String])
-> (Set (String, String) -> [(String, String)])
-> Set (String, String)
-> [Link String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (String, String) -> [(String, String)]
forall a. Set a -> [a]
S.toList
      (Set (String, String) -> [Link String String])
-> f (Set (String, String)) -> f [Link String String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> (String -> Int -> f String)
-> (String -> Int -> f String)
-> AlloySig
-> f (Set (String, String))
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
l String -> Int -> f String
forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> m String
oName String -> Int -> f String
forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> m String
oName AlloySig
os
    getLinks :: f AlloySig -> String -> m [Link String String]
getLinks f AlloySig
os String
l = ((String, String) -> Link String String)
-> [(String, String)] -> [Link String String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> (String, String) -> Link String String
forall {linkLabel} {objectName}.
linkLabel -> (objectName, objectName) -> Link objectName linkLabel
toLink String
l) ([(String, String)] -> [Link String String])
-> (f (Set (String, String)) -> [(String, String)])
-> f (Set (String, String))
-> [Link String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (String, String) -> [(String, String)]
forall a. Set a -> [a]
S.toList (Set (String, String) -> [(String, String)])
-> (f (Set (String, String)) -> Set (String, String))
-> f (Set (String, String))
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Set (String, String)) -> Set (String, String)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions
      (f (Set (String, String)) -> [Link String String])
-> m (f (Set (String, String))) -> m [Link String String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AlloySig -> m (Set (String, String)))
-> f AlloySig -> m (f (Set (String, String)))
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) -> f a -> m (f b)
mapM (m (Set (String, String)) -> m (Set (String, String))
forall {a}. m (Set a) -> m (Set a)
ignoreMissingRelation (m (Set (String, String)) -> m (Set (String, String)))
-> (AlloySig -> m (Set (String, String)))
-> AlloySig
-> m (Set (String, String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (String -> Int -> m String)
-> (String -> Int -> m String)
-> AlloySig
-> m (Set (String, String))
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
l String -> Int -> m String
forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> m String
oName String -> Int -> m String
forall {m :: * -> *} {a}.
(Monad m, Eq a, Num a, Show a) =>
String -> a -> m String
oName) f AlloySig
os
    ignoreMissingRelation :: m (Set a) -> m (Set a)
ignoreMissingRelation = (m (Set a) -> (AlloyLookupFailed -> m (Set a)) -> m (Set a))
-> (AlloyLookupFailed -> m (Set a)) -> m (Set a) -> m (Set a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Set a) -> (AlloyLookupFailed -> m (Set a)) -> m (Set a)
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch ((AlloyLookupFailed -> m (Set a)) -> m (Set a) -> m (Set a))
-> (AlloyLookupFailed -> m (Set a)) -> m (Set a) -> m (Set a)
forall a b. (a -> b) -> a -> b
$ \case
      LookupAlloyRelationFailed {} -> Set a -> m (Set a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set a
forall a. Set a
S.empty
      AlloyLookupFailed
exception -> AlloyLookupFailed -> m (Set a)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM AlloyLookupFailed
exception
    oName :: String -> a -> m String
oName String
x = String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> (a -> String) -> a -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> String
forall {a}. (Eq a, Num a, Show a) => String -> a -> String
toObjectName String
x
    toObjectName :: String -> a -> String
toObjectName String
x a
y = String -> String
lowerFirst String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ if a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then [] else a -> String
forall a. Show a => a -> String
show a
y
    toObject :: String -> a -> m (Object String String)
toObject String
x a
y = Object String String -> m (Object String String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object String String -> m (Object String String))
-> Object String String -> m (Object String String)
forall a b. (a -> b) -> a -> b
$ Object {
      isAnonymous :: Bool
isAnonymous = Bool
False,
      objectName :: String
objectName = String -> a -> String
forall {a}. (Eq a, Num a, Show a) => String -> a -> String
toObjectName String
x a
y,
      objectClass :: String
objectClass = String
x
      }
    toLink :: linkLabel -> (objectName, objectName) -> Link objectName linkLabel
toLink linkLabel
l (objectName
x, objectName
y) = Link {
      linkLabel :: linkLabel
linkLabel = linkLabel
l,
      linkFrom :: objectName
linkFrom = objectName
x,
      linkTo :: objectName
linkTo = objectName
y
      }

oneAndOther
  :: String
  -> String
  -> (DefaultedLimitedLinking, DefaultedLimitedLinking)
  -> (DefaultedLimitedLinking, DefaultedLimitedLinking)
oneAndOther :: String
-> String
-> (DefaultedLimitedLinking, DefaultedLimitedLinking)
-> (DefaultedLimitedLinking, DefaultedLimitedLinking)
oneAndOther String
linking1 String
linking2 (DefaultedLimitedLinking
limit1, DefaultedLimitedLinking
limit2) = (
  DefaultedLimitedLinking
limit1 {defaultedLinking :: String
defaultedLinking = String
linking1},
  DefaultedLimitedLinking
limit2 {defaultedLinking :: String
defaultedLinking = String
linking2}
  )