{-# LANGUAGE PostfixOperators, Rank2Types, ScopedTypeVariables, TemplateHaskell,
FlexibleInstances, MultiParamTypeClasses, TupleSections #-}
module Theory.Drasil.MultiDefn(
MultiDefn, DefiningExpr,
mkMultiDefn, mkMultiDefnForQuant, mkDefiningExpr,
multiDefnGenQD, multiDefnGenQDByUID,
) where
import Control.Lens (makeLenses, view, (^.))
import Data.List (union)
import qualified Data.List.NonEmpty as NE
import Language.Drasil hiding (DefiningExpr)
data DefiningExpr e = DefiningExpr
{
forall e. DefiningExpr e -> UID
_deUid :: UID,
forall e. DefiningExpr e -> [UID]
_cd :: [UID],
forall e. DefiningExpr e -> Sentence
_rvDesc :: Sentence,
forall e. DefiningExpr e -> e
_expr :: e
}
makeLenses ''DefiningExpr
instance Eq (DefiningExpr e) where DefiningExpr e
a == :: DefiningExpr e -> DefiningExpr e -> Bool
== 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 => Getter c UID
Getter (DefiningExpr e) 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 => Getter c UID
Getter (DefiningExpr e) UID
uid
instance HasUID (DefiningExpr e) where uid :: Getter (DefiningExpr e) UID
uid = (UID -> f UID) -> DefiningExpr e -> f (DefiningExpr e)
forall e (f :: * -> *).
Functor f =>
(UID -> f UID) -> DefiningExpr e -> f (DefiningExpr e)
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 (f :: * -> *).
Functor f =>
([UID] -> f [UID]) -> DefiningExpr e -> f (DefiningExpr e)
cd)
instance Definition (DefiningExpr e) where defn :: Lens' (DefiningExpr e) Sentence
defn = (Sentence -> f Sentence) -> DefiningExpr e -> f (DefiningExpr e)
forall e (f :: * -> *).
Functor f =>
(Sentence -> f Sentence) -> DefiningExpr e -> f (DefiningExpr e)
rvDesc
data MultiDefn e = MultiDefn{
forall e. MultiDefn e -> UID
_rUid :: UID,
forall e. MultiDefn e -> QuantityDict
_qd :: QuantityDict,
forall e. MultiDefn e -> Sentence
_rDesc :: Sentence,
forall e. MultiDefn e -> NonEmpty (DefiningExpr e)
_rvs :: NE.NonEmpty (DefiningExpr e)
}
makeLenses ''MultiDefn
instance HasUID (MultiDefn e) where uid :: Getter (MultiDefn e) UID
uid = (UID -> f UID) -> MultiDefn e -> f (MultiDefn e)
forall e (f :: * -> *).
Functor f =>
(UID -> f UID) -> MultiDefn e -> f (MultiDefn e)
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 (f :: * -> *).
Functor f =>
(QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
qd)
instance NamedIdea (MultiDefn e) where term :: Lens' (MultiDefn e) NP
term = (QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
forall e (f :: * -> *).
Functor f =>
(QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
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
Lens' QuantityDict 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 (f :: * -> *).
Functor f =>
(QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
qd)
instance HasSpace (MultiDefn e) where typ :: Getter (MultiDefn e) Space
typ = (QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
forall e (f :: * -> *).
Functor f =>
(QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
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 => Getter c Space
Getter QuantityDict Space
typ
instance Definition (MultiDefn e) where defn :: Lens' (MultiDefn e) Sentence
defn = (Sentence -> f Sentence) -> MultiDefn e -> f (MultiDefn e)
forall e (f :: * -> *).
Functor f =>
(Sentence -> f Sentence) -> MultiDefn e -> f (MultiDefn e)
rDesc
instance Quantity (MultiDefn e)
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 (f :: * -> *).
Functor f =>
(QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
qd
instance ConceptDomain (MultiDefn e) where
cdom :: MultiDefn e -> [UID]
cdom = ([UID] -> [UID] -> [UID]) -> [[UID]] -> [UID]
forall a. (a -> a -> a) -> [a] -> a
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 (f :: * -> *).
Functor f =>
([UID] -> f [UID]) -> DefiningExpr e -> f (DefiningExpr e)
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 (f :: * -> *).
Functor f =>
(NonEmpty (DefiningExpr e) -> f (NonEmpty (DefiningExpr e)))
-> MultiDefn e -> f (MultiDefn e)
rvs)
instance RequiresChecking (MultiDefn Expr) Expr Space where
requiredChecks :: MultiDefn Expr -> [(Expr, Space)]
requiredChecks MultiDefn Expr
md = (DefiningExpr Expr -> (Expr, Space))
-> [DefiningExpr Expr] -> [(Expr, Space)]
forall a b. (a -> b) -> [a] -> [b]
map (\DefiningExpr Expr
x -> (DefiningExpr Expr
x DefiningExpr Expr -> Getting Expr (DefiningExpr Expr) Expr -> Expr
forall s a. s -> Getting a s a -> a
^. Getting Expr (DefiningExpr Expr) Expr
forall e e (f :: * -> *).
Functor f =>
(e -> f e) -> DefiningExpr e -> f (DefiningExpr e)
expr, MultiDefn Expr
md MultiDefn Expr -> Getting Space (MultiDefn Expr) Space -> Space
forall s a. s -> Getting a s a -> a
^. Getting Space (MultiDefn Expr) Space
forall c. HasSpace c => Getter c Space
Getter (MultiDefn Expr) Space
typ)) ([DefiningExpr Expr] -> [(Expr, Space)])
-> [DefiningExpr Expr] -> [(Expr, Space)]
forall a b. (a -> b) -> a -> b
$ NonEmpty (DefiningExpr Expr) -> [DefiningExpr Expr]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (DefiningExpr Expr) -> [DefiningExpr Expr])
-> NonEmpty (DefiningExpr Expr) -> [DefiningExpr Expr]
forall a b. (a -> b) -> a -> b
$ MultiDefn Expr
md MultiDefn Expr
-> Getting
(NonEmpty (DefiningExpr Expr))
(MultiDefn Expr)
(NonEmpty (DefiningExpr Expr))
-> NonEmpty (DefiningExpr Expr)
forall s a. s -> Getting a s a -> a
^. Getting
(NonEmpty (DefiningExpr Expr))
(MultiDefn Expr)
(NonEmpty (DefiningExpr Expr))
forall e e (f :: * -> *).
Functor f =>
(NonEmpty (DefiningExpr e) -> f (NonEmpty (DefiningExpr e)))
-> MultiDefn e -> f (MultiDefn e)
rvs
instance Express e => Express (MultiDefn e) where
express :: MultiDefn e -> ModelExpr
express 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 c. (HasUID c, HasSymbol c) => c -> 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 (f :: * -> *).
Functor f =>
(e -> f e) -> DefiningExpr e -> f (DefiningExpr 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 (f :: * -> *).
Functor f =>
(NonEmpty (DefiningExpr e) -> f (NonEmpty (DefiningExpr e)))
-> MultiDefn e -> f (MultiDefn e)
rvs))
mkMultiDefn :: String -> QuantityDict -> Sentence -> NE.NonEmpty (DefiningExpr e) -> MultiDefn e
mkMultiDefn :: forall e.
String
-> QuantityDict
-> Sentence
-> NonEmpty (DefiningExpr e)
-> MultiDefn e
mkMultiDefn String
u QuantityDict
q Sentence
s NonEmpty (DefiningExpr e)
des
| NonEmpty (DefiningExpr e) -> Int
forall a. NonEmpty a -> 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
$
String
"MultiDefn `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` created with non-unique list of expressions"
where
dupsRemovedLen :: Int
dupsRemovedLen = NonEmpty (DefiningExpr e) -> Int
forall a. NonEmpty a -> 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
mkMultiDefnForQuant :: QuantityDict -> Sentence -> NE.NonEmpty (DefiningExpr e) -> MultiDefn e
mkMultiDefnForQuant :: forall e.
QuantityDict
-> Sentence -> NonEmpty (DefiningExpr e) -> MultiDefn e
mkMultiDefnForQuant 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
mkDefiningExpr :: String -> [UID] -> Sentence -> e -> DefiningExpr e
mkDefiningExpr :: forall e. String -> [UID] -> Sentence -> e -> DefiningExpr e
mkDefiningExpr String
u = UID -> [UID] -> Sentence -> e -> DefiningExpr e
forall e. UID -> [UID] -> Sentence -> e -> DefiningExpr e
DefiningExpr (String -> UID
mkUid String
u)
multiDefnGenQD :: MultiDefn e -> DefiningExpr e -> QDefinition e
multiDefnGenQD :: forall e. MultiDefn e -> DefiningExpr e -> QDefinition e
multiDefnGenQD MultiDefn e
md 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 (f :: * -> *).
Functor f =>
(QuantityDict -> f QuantityDict) -> MultiDefn e -> f (MultiDefn e)
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 => Getter c UID
Getter QuantityDict 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
Lens' (MultiDefn e) 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
Lens' (MultiDefn e) 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 => Getter c Space
Getter (MultiDefn e) 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 (f :: * -> *).
Functor f =>
(e -> f e) -> DefiningExpr e -> f (DefiningExpr e)
expr)
multiDefnGenQDByUID :: MultiDefn e -> UID -> QDefinition e
multiDefnGenQDByUID :: forall e. MultiDefn e -> UID -> QDefinition e
multiDefnGenQDByUID MultiDefn e
md UID
u
| [DefiningExpr e] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DefiningExpr e]
matches Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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
$
String
"Invalid defining expression `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UID -> String
forall a. Show a => a -> String
show UID
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` for QDef creation in MultiDefn `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UID -> String
forall a. Show a => a -> String
show UID
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`"
where
matches :: [DefiningExpr e]
matches = (DefiningExpr e -> Bool)
-> NonEmpty (DefiningExpr e) -> [DefiningExpr e]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (\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 => Getter c UID
Getter (DefiningExpr e) 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 (f :: * -> *).
Functor f =>
(NonEmpty (DefiningExpr e) -> f (NonEmpty (DefiningExpr e)))
-> MultiDefn e -> f (MultiDefn e)
rvs)
matched :: DefiningExpr e
matched = [DefiningExpr e] -> DefiningExpr e
forall a. HasCallStack => [a] -> a
head [DefiningExpr e]
matches