{-# LANGUAGE DeriveDataTypeable #-}
module Domain.Math.Expr.Clipboard
(
Clipboard
, addToClipboard, removeClipboard, lookupClipboard
, addToClipboardG, lookupClipboardG
) where
import Data.Maybe
import Data.Typeable
import Domain.Math.Data.Relation
import Domain.Math.Expr.Data
import Domain.Math.Expr.Parser
import Ideas.Common.Library
import qualified Data.Map as M
newtype Clipboard = C {unC :: M.Map String Expr}
deriving Typeable
instance Show Clipboard where
show = show . toExpr
instance Read Clipboard where
readsPrec _ txt = do
expr <- parseExprM txt
clip <- fromExpr expr
return (clip, "")
instance IsTerm Clipboard where
toTerm =
let f (s, a) = Var s :==: a
in toTerm . map f . M.toList . unC
fromTerm =
let f (x :==: a) = (\k -> (k, a)) <$> getVariable x
in fmap (C . M.fromList) . mapM f . fromTerm
instance Reference Clipboard
clipboard :: Ref Clipboard
clipboard = makeRef "clipboard"
getClipboard :: Context a -> Clipboard
getClipboard = fromMaybe (C M.empty) . (clipboard ?)
changeClipboard :: (Clipboard -> Clipboard) -> Context a -> Context a
changeClipboard f c = insertRef clipboard (f (getClipboard c)) c
addToClipboard :: String -> Expr -> Context a -> Context a
addToClipboard = addToClipboardG
lookupClipboard :: String -> Context b -> Maybe Expr
lookupClipboard = lookupClipboardG
removeClipboard :: String -> Context a -> Context a
removeClipboard s = changeClipboard (C . M.delete s . unC)
addToClipboardG :: IsTerm a => String -> a -> Context b -> Context b
addToClipboardG s a = changeClipboard (C . M.insert s (toExpr a) . unC)
lookupClipboardG :: IsTerm a => String -> Context b -> Maybe a
lookupClipboardG s c = clipboard ? c >>= M.lookup s . unC >>= fromExpr