{-# LANGUAGE TemplateHaskell, Rank2Types, ScopedTypeVariables, PostfixOperators  #-}

-- | Defines types and functions for creating mult-definitions.
module Theory.Drasil.MultiDefn (
  -- * Types
  MultiDefn, DefiningExpr,
  -- * Constructors
  mkMultiDefn, mkMultiDefnForQuant, mkDefiningExpr,
  -- * Functions
  multiDefnGenQD, multiDefnGenQDByUID) where

import Control.Lens ((^.), view, makeLenses)
import Data.List (union)
import qualified Data.List.NonEmpty as NE

import Language.Drasil hiding (DefiningExpr)
import Language.Drasil.Development (showUID)

-- | 'DefiningExpr' are the data that make up a (quantity) definition, namely
--   the description, the defining (rhs) expression and the context domain(s).
--   These are meant to be 'alternate' but equivalent definitions for a single concept.
data DefiningExpr e = DefiningExpr {
  DefiningExpr e -> UID
_deUid  :: UID,            -- ^ UID
  DefiningExpr e -> [UID]
_cd     :: [UID],          -- ^ Concept domain
  DefiningExpr e -> Sentence
_rvDesc :: Sentence,       -- ^ Defining description/statement
  DefiningExpr e -> e
_expr   :: e  -- ^ Defining expression
}
makeLenses ''DefiningExpr

instance Eq            (DefiningExpr e) where a :: DefiningExpr e
a == :: DefiningExpr e -> DefiningExpr e -> Bool
== b :: DefiningExpr e
b = DefiningExpr e
a DefiningExpr e -> Getting UID (DefiningExpr e) UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID (DefiningExpr e) UID
forall c. HasUID c => Lens' c UID
uid UID -> UID -> Bool
forall a. Eq a => a -> a -> Bool
== DefiningExpr e
b DefiningExpr e -> Getting UID (DefiningExpr e) UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID (DefiningExpr e) UID
forall c. HasUID c => Lens' c UID
uid
instance HasUID        (DefiningExpr e) where uid :: (UID -> f UID) -> DefiningExpr e -> f (DefiningExpr e)
uid    = (UID -> f UID) -> DefiningExpr e -> f (DefiningExpr e)
forall e. Lens' (DefiningExpr e) UID
deUid
instance ConceptDomain (DefiningExpr e) where cdom :: DefiningExpr e -> [UID]
cdom   = (DefiningExpr e -> Getting [UID] (DefiningExpr e) [UID] -> [UID]
forall s a. s -> Getting a s a -> a
^. Getting [UID] (DefiningExpr e) [UID]
forall e. Lens' (DefiningExpr e) [UID]
cd)
instance Definition    (DefiningExpr e) where defn :: (Sentence -> f Sentence) -> DefiningExpr e -> f (DefiningExpr e)
defn   = (Sentence -> f Sentence) -> DefiningExpr e -> f (DefiningExpr e)
forall e. Lens' (DefiningExpr e) Sentence
rvDesc

-- | 'MultiDefn's are QDefinition factories, used for showing one or more ways we
--   can define a QDefinition.
data MultiDefn e = MultiDefn {
    MultiDefn e -> UID
_rUid  :: UID,                                      -- ^ UID
    MultiDefn e -> QuantityDict
_qd    :: QuantityDict,                             -- ^ Underlying quantity it defines
    MultiDefn e -> Sentence
_rDesc :: Sentence,                                 -- ^ Defining description/statement
    MultiDefn e -> NonEmpty (DefiningExpr e)
_rvs   :: NE.NonEmpty (DefiningExpr e) -- ^ All possible/omitted ways we can define the related quantity
           -- TODO: Why is this above constraint redundant according to the smart constructors?
}
makeLenses ''MultiDefn


instance HasUID        (MultiDefn e) where uid :: (UID -> f UID) -> MultiDefn e -> f (MultiDefn e)
uid     = (UID -> f UID) -> MultiDefn e -> f (MultiDefn e)
forall e. Lens' (MultiDefn e) UID
rUid
instance HasSymbol     (MultiDefn e) where symbol :: MultiDefn e -> Stage -> Symbol
symbol  = QuantityDict -> Stage -> Symbol
forall c. HasSymbol c => c -> Stage -> Symbol
symbol (QuantityDict -> Stage -> Symbol)
-> (MultiDefn e -> QuantityDict) -> MultiDefn e -> Stage -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiDefn e
-> Getting QuantityDict (MultiDefn e) QuantityDict -> QuantityDict
forall s a. s -> Getting a s a -> a
^. Getting QuantityDict (MultiDefn e) QuantityDict
forall e. Lens' (MultiDefn e) QuantityDict
qd)
instance NamedIdea     (MultiDefn e) where term :: (NP -> f NP) -> MultiDefn e -> f (MultiDefn e)
term    = (QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
forall e. Lens' (MultiDefn e) QuantityDict
qd ((QuantityDict -> f QuantityDict)
 -> MultiDefn e -> f (MultiDefn e))
-> ((NP -> f NP) -> QuantityDict -> f QuantityDict)
-> (NP -> f NP)
-> MultiDefn e
-> f (MultiDefn e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP -> f NP) -> QuantityDict -> f QuantityDict
forall c. NamedIdea c => Lens' c NP
term
instance Idea          (MultiDefn e) where getA :: MultiDefn e -> Maybe String
getA    = QuantityDict -> Maybe String
forall c. Idea c => c -> Maybe String
getA (QuantityDict -> Maybe String)
-> (MultiDefn e -> QuantityDict) -> MultiDefn e -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiDefn e
-> Getting QuantityDict (MultiDefn e) QuantityDict -> QuantityDict
forall s a. s -> Getting a s a -> a
^. Getting QuantityDict (MultiDefn e) QuantityDict
forall e. Lens' (MultiDefn e) QuantityDict
qd)
instance HasSpace      (MultiDefn e) where typ :: (Space -> f Space) -> MultiDefn e -> f (MultiDefn e)
typ     = (QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
forall e. Lens' (MultiDefn e) QuantityDict
qd ((QuantityDict -> f QuantityDict)
 -> MultiDefn e -> f (MultiDefn e))
-> ((Space -> f Space) -> QuantityDict -> f QuantityDict)
-> (Space -> f Space)
-> MultiDefn e
-> f (MultiDefn e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Space -> f Space) -> QuantityDict -> f QuantityDict
forall c. HasSpace c => Lens' c Space
typ
instance Quantity      (MultiDefn e) where
instance MayHaveUnit   (MultiDefn e) where getUnit :: MultiDefn e -> Maybe UnitDefn
getUnit = QuantityDict -> Maybe UnitDefn
forall u. MayHaveUnit u => u -> Maybe UnitDefn
getUnit (QuantityDict -> Maybe UnitDefn)
-> (MultiDefn e -> QuantityDict) -> MultiDefn e -> Maybe UnitDefn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting QuantityDict (MultiDefn e) QuantityDict
-> MultiDefn e -> QuantityDict
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting QuantityDict (MultiDefn e) QuantityDict
forall e. Lens' (MultiDefn e) QuantityDict
qd
-- | The concept domain of a MultiDefn is the union of the concept domains of the underlying variants.
instance ConceptDomain (MultiDefn e) where cdom :: MultiDefn e -> [UID]
cdom    = ([UID] -> [UID] -> [UID]) -> [[UID]] -> [UID]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [UID] -> [UID] -> [UID]
forall a. Eq a => [a] -> [a] -> [a]
union ([[UID]] -> [UID])
-> (MultiDefn e -> [[UID]]) -> MultiDefn e -> [UID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [UID] -> [[UID]]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty [UID] -> [[UID]])
-> (MultiDefn e -> NonEmpty [UID]) -> MultiDefn e -> [[UID]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefiningExpr e -> [UID])
-> NonEmpty (DefiningExpr e) -> NonEmpty [UID]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (DefiningExpr e -> Getting [UID] (DefiningExpr e) [UID] -> [UID]
forall s a. s -> Getting a s a -> a
^. Getting [UID] (DefiningExpr e) [UID]
forall e. Lens' (DefiningExpr e) [UID]
cd) (NonEmpty (DefiningExpr e) -> NonEmpty [UID])
-> (MultiDefn e -> NonEmpty (DefiningExpr e))
-> MultiDefn e
-> NonEmpty [UID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiDefn e
-> Getting
     (NonEmpty (DefiningExpr e))
     (MultiDefn e)
     (NonEmpty (DefiningExpr e))
-> NonEmpty (DefiningExpr e)
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty (DefiningExpr e))
  (MultiDefn e)
  (NonEmpty (DefiningExpr e))
forall e e.
Lens
  (MultiDefn e)
  (MultiDefn e)
  (NonEmpty (DefiningExpr e))
  (NonEmpty (DefiningExpr e))
rvs)
instance Definition    (MultiDefn e) where defn :: (Sentence -> f Sentence) -> MultiDefn e -> f (MultiDefn e)
defn    = (Sentence -> f Sentence) -> MultiDefn e -> f (MultiDefn e)
forall e. Lens' (MultiDefn e) Sentence
rDesc
-- | The complete Relation of a MultiDefn is defined as the quantity and the related expressions being equal
--   e.g., `q $= a $= b $= ... $= z`
instance Express e => Express (MultiDefn e) where
  express :: MultiDefn e -> ModelExpr
express q :: MultiDefn e
q = [ModelExpr] -> ModelExpr
forall r. ModelExprC r => [r] -> r
equiv ([ModelExpr] -> ModelExpr) -> [ModelExpr] -> ModelExpr
forall a b. (a -> b) -> a -> b
$ MultiDefn e -> ModelExpr
forall r c. (ExprC r, HasUID c, HasSymbol c) => c -> r
sy MultiDefn e
q ModelExpr -> [ModelExpr] -> [ModelExpr]
forall a. a -> [a] -> [a]
: NonEmpty ModelExpr -> [ModelExpr]
forall a. NonEmpty a -> [a]
NE.toList ((DefiningExpr e -> ModelExpr)
-> NonEmpty (DefiningExpr e) -> NonEmpty ModelExpr
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (e -> ModelExpr
forall c. Express c => c -> ModelExpr
express (e -> ModelExpr)
-> (DefiningExpr e -> e) -> DefiningExpr e -> ModelExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefiningExpr e -> Getting e (DefiningExpr e) e -> e
forall s a. s -> Getting a s a -> a
^. Getting e (DefiningExpr e) e
forall e e. Lens (DefiningExpr e) (DefiningExpr e) e e
expr)) (MultiDefn e
q MultiDefn e
-> Getting
     (NonEmpty (DefiningExpr e))
     (MultiDefn e)
     (NonEmpty (DefiningExpr e))
-> NonEmpty (DefiningExpr e)
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty (DefiningExpr e))
  (MultiDefn e)
  (NonEmpty (DefiningExpr e))
forall e e.
Lens
  (MultiDefn e)
  (MultiDefn e)
  (NonEmpty (DefiningExpr e))
  (NonEmpty (DefiningExpr e))
rvs))

-- | Smart constructor for MultiDefns, does nothing special at the moment. First argument is the 'String' to become a 'UID'.
mkMultiDefn :: String -> QuantityDict -> Sentence -> NE.NonEmpty (DefiningExpr e) -> MultiDefn e
mkMultiDefn :: String
-> QuantityDict
-> Sentence
-> NonEmpty (DefiningExpr e)
-> MultiDefn e
mkMultiDefn u :: String
u q :: QuantityDict
q s :: Sentence
s des :: NonEmpty (DefiningExpr e)
des
  | NonEmpty (DefiningExpr e) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (DefiningExpr e)
des Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
dupsRemovedLen = UID
-> QuantityDict
-> Sentence
-> NonEmpty (DefiningExpr e)
-> MultiDefn e
forall e.
UID
-> QuantityDict
-> Sentence
-> NonEmpty (DefiningExpr e)
-> MultiDefn e
MultiDefn (String -> UID
mkUid String
u) QuantityDict
q Sentence
s NonEmpty (DefiningExpr e)
des
  | Bool
otherwise                    = String -> MultiDefn e
forall a. HasCallStack => String -> a
error (String -> MultiDefn e) -> String -> MultiDefn e
forall a b. (a -> b) -> a -> b
$
    "MultiDefn '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' created with non-unique list of expressions"
  where dupsRemovedLen :: Int
dupsRemovedLen = NonEmpty (DefiningExpr e) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NonEmpty (DefiningExpr e) -> Int)
-> NonEmpty (DefiningExpr e) -> Int
forall a b. (a -> b) -> a -> b
$ NonEmpty (DefiningExpr e) -> NonEmpty (DefiningExpr e)
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub NonEmpty (DefiningExpr e)
des

-- Should showUID be used here?
-- | Smart constructor for 'MultiDefn's defining 'UID's using that of the 'QuantityDict'.
mkMultiDefnForQuant :: QuantityDict -> Sentence -> NE.NonEmpty (DefiningExpr e) -> MultiDefn e
mkMultiDefnForQuant :: QuantityDict
-> Sentence -> NonEmpty (DefiningExpr e) -> MultiDefn e
mkMultiDefnForQuant q :: QuantityDict
q = String
-> QuantityDict
-> Sentence
-> NonEmpty (DefiningExpr e)
-> MultiDefn e
forall e.
String
-> QuantityDict
-> Sentence
-> NonEmpty (DefiningExpr e)
-> MultiDefn e
mkMultiDefn (QuantityDict -> String
forall a. HasUID a => a -> String
showUID QuantityDict
q) QuantityDict
q

-- | Smart constructor for 'DefiningExpr's.
mkDefiningExpr :: String -> [UID] -> Sentence -> e -> DefiningExpr e
mkDefiningExpr :: String -> [UID] -> Sentence -> e -> DefiningExpr e
mkDefiningExpr u :: String
u = UID -> [UID] -> Sentence -> e -> DefiningExpr e
forall e. UID -> [UID] -> Sentence -> e -> DefiningExpr e
DefiningExpr (String -> UID
mkUid String
u)

-- | Convert 'MultiDefn's into 'QDefinition's via a specific 'DefiningExpr'.
multiDefnGenQD :: MultiDefn e -> DefiningExpr e -> QDefinition e
multiDefnGenQD :: MultiDefn e -> DefiningExpr e -> QDefinition e
multiDefnGenQD md :: MultiDefn e
md de :: DefiningExpr e
de = UID
-> NP
-> Sentence
-> (Stage -> Symbol)
-> Space
-> Maybe UnitDefn
-> e
-> QDefinition e
forall e.
UID
-> NP
-> Sentence
-> (Stage -> Symbol)
-> Space
-> Maybe UnitDefn
-> e
-> QDefinition e
mkQDefSt (MultiDefn e
md MultiDefn e -> Getting UID (MultiDefn e) UID -> UID
forall s a. s -> Getting a s a -> a
^. (QuantityDict -> Const UID QuantityDict)
-> MultiDefn e -> Const UID (MultiDefn e)
forall e. Lens' (MultiDefn e) QuantityDict
qd ((QuantityDict -> Const UID QuantityDict)
 -> MultiDefn e -> Const UID (MultiDefn e))
-> ((UID -> Const UID UID)
    -> QuantityDict -> Const UID QuantityDict)
-> Getting UID (MultiDefn e) UID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UID -> Const UID UID) -> QuantityDict -> Const UID QuantityDict
forall c. HasUID c => Lens' c UID
uid) (MultiDefn e
md MultiDefn e -> Getting NP (MultiDefn e) NP -> NP
forall s a. s -> Getting a s a -> a
^. Getting NP (MultiDefn e) NP
forall c. NamedIdea c => Lens' c NP
term) (MultiDefn e
md MultiDefn e -> Getting Sentence (MultiDefn e) Sentence -> Sentence
forall s a. s -> Getting a s a -> a
^. Getting Sentence (MultiDefn e) Sentence
forall c. Definition c => Lens' c Sentence
defn)
                                (MultiDefn e -> Stage -> Symbol
forall c. HasSymbol c => c -> Stage -> Symbol
symbol MultiDefn e
md) (MultiDefn e
md MultiDefn e -> Getting Space (MultiDefn e) Space -> Space
forall s a. s -> Getting a s a -> a
^. Getting Space (MultiDefn e) Space
forall c. HasSpace c => Lens' c Space
typ) (MultiDefn e -> Maybe UnitDefn
forall u. MayHaveUnit u => u -> Maybe UnitDefn
getUnit MultiDefn e
md) (DefiningExpr e
de DefiningExpr e -> Getting e (DefiningExpr e) e -> e
forall s a. s -> Getting a s a -> a
^. Getting e (DefiningExpr e) e
forall e e. Lens (DefiningExpr e) (DefiningExpr e) e e
expr)

-- | Convert 'MultiDefn's into 'QDefinition's via a specific 'DefiningExpr' (by 'UID').
multiDefnGenQDByUID :: MultiDefn e -> UID -> QDefinition e
multiDefnGenQDByUID :: MultiDefn e -> UID -> QDefinition e
multiDefnGenQDByUID md :: MultiDefn e
md u :: UID
u | [DefiningExpr e] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DefiningExpr e]
matches Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = MultiDefn e -> DefiningExpr e -> QDefinition e
forall e. MultiDefn e -> DefiningExpr e -> QDefinition e
multiDefnGenQD MultiDefn e
md DefiningExpr e
matched
                         | Bool
otherwise           = String -> QDefinition e
forall a. HasCallStack => String -> a
error (String -> QDefinition e) -> String -> QDefinition e
forall a b. (a -> b) -> a -> b
$ "Invalid UID for multiDefn QD generation; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UID -> String
forall a. Show a => a -> String
show UID
u
  where matches :: [DefiningExpr e]
matches = (DefiningExpr e -> Bool)
-> NonEmpty (DefiningExpr e) -> [DefiningExpr e]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (\x :: DefiningExpr e
x -> DefiningExpr e
x DefiningExpr e -> Getting UID (DefiningExpr e) UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID (DefiningExpr e) UID
forall c. HasUID c => Lens' c UID
uid UID -> UID -> Bool
forall a. Eq a => a -> a -> Bool
== UID
u) (MultiDefn e
md MultiDefn e
-> Getting
     (NonEmpty (DefiningExpr e))
     (MultiDefn e)
     (NonEmpty (DefiningExpr e))
-> NonEmpty (DefiningExpr e)
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty (DefiningExpr e))
  (MultiDefn e)
  (NonEmpty (DefiningExpr e))
forall e e.
Lens
  (MultiDefn e)
  (MultiDefn e)
  (NonEmpty (DefiningExpr e))
  (NonEmpty (DefiningExpr e))
rvs)
        matched :: DefiningExpr e
matched = [DefiningExpr e] -> DefiningExpr e
forall a. [a] -> a
head [DefiningExpr e]
matches