{-# LANGUAGE CPP,MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,OverloadedStrings,Rank2Types,ScopedTypeVariables #-}
module Control.Provenience (
Variable(..)
,VariableStore
,var
,varM
,input
,inputM
,func
,StoreUpdate
,(<?)
,named
,linkto
,render
,renderWith
,renderShow
,DefaultRender(..)
,Proveniencei18n(..)
,enProveniencei18n
,deProveniencei18n
,renderStore
,renderSheet
,graphAltReps
,graphShortnames
,ProvenienceT(..)
,Provenience
,(<%>)
,(<%%>)
,runProvenienceT
,execProvenienceT
,execProvenience
,evalProvenienceT
,evalProvenience
,sequenceProvenienceT) where
import Control.Monad
import Control.Monad.State.Strict
import Control.Arrow
import Data.Functor.Identity
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query.DFS (topsort)
import Data.Default
import Data.Ratio
import Data.Monoid
import Data.Word (Word64)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Representation
import Data.Spreadsheet
import qualified Data.Set as Set
import Data.Text (Text,pack,unpack)
import Text.Pandoc
import Numeric (showHex)
data VariableDesc alt = VariableDesc {
shortname :: Maybe String,
description :: Block,
valueRendering :: Block,
altRep :: alt
}
data VariableStore alt = VariableStore {
dependencyGraph :: Gr (VariableDesc alt) Block,
nextFreeNode :: Node}
graphAltReps :: VariableStore alt -> Gr alt Block
graphAltReps = nmap altRep . dependencyGraph
graphShortnames :: VariableStore alt -> Gr String Block
graphShortnames = nmap (maybe "" id . shortname) . dependencyGraph
getDescription :: Node -> VariableStore alt -> Maybe (VariableDesc alt)
getDescription i store = case match i (dependencyGraph store) of
(Nothing,_) -> Nothing
(Just (_,_,desc,_),_) -> Just desc
getShortname :: Node -> VariableStore alt -> Maybe String
getShortname i = getDescription i >=> shortname
data Variable a = Variable {
identifier :: Node,
value :: a}
instance Functor Variable where
fmap f x = x {value = f (value x)}
instance Show a => Show (Variable a) where
show v = show (value v)
linkname :: Variable a -> String
linkname = linknode . identifier
linknode :: Node -> String
linknode n = "provenienceVar" ++ showHex n ""
type ProvenienceT alt m a = StateT (VariableStore alt) m (Variable a)
type Provenience a = State (VariableStore ()) (Variable a)
type StoreUpdate = forall m alt. Monad m => StateT (VariableStore alt) m ()
class DefaultRender a where
renderDefault :: a -> Block
#if MIN_VERSION_pandoc(2,8,0)
instance DefaultRender String where
renderDefault = Para . pure . Str . pack
#else
instance DefaultRender String where
renderDefault = Para . pure . Str
#endif
instance DefaultRender Block where
renderDefault = id
#if MIN_VERSION_pandoc(2,8,0)
instance DefaultRender Text where
renderDefault = Para . pure . Str
#else
instance DefaultRender Text where
renderDefault = Para . pure . Str . unpack
#endif
instance DefaultRender Char where
renderDefault = renderDefault . (pure :: Char -> String)
instance DefaultRender Int where
renderDefault = renderShow
instance DefaultRender Integer where
renderDefault = renderShow
instance DefaultRender Double where
renderDefault = renderShow
#if MIN_VERSION_pandoc(2,8,0)
instance DefaultRender (Ratio Integer) where
renderDefault x = Plain [Math InlineMath (pack $ "\\frac{"++(show (numerator x))++"}{"++(show (denominator x))++"}")]
#else
instance DefaultRender (Ratio Integer) where
renderDefault x = Plain [Math InlineMath ("\\frac{"++(show (numerator x))++"}{"++(show (denominator x))++"}")]
#endif
renderWith :: (Representation a alt, Monad m) => (a -> Block) -> Variable a -> StateT (VariableStore alt) m ()
renderWith method v = modify' (\vs -> changeLabel (identifier v) (\desc -> desc {valueRendering = method (value v), altRep = representation (value v)}) vs)
renderShow :: Show a => a -> Block
renderShow = Plain . pure . Str . show
render :: (Representation a alt, Monad m, DefaultRender a) => Variable a -> StateT (VariableStore alt) m ()
render = renderWith renderDefault
data Proveniencei18n = Proveniencei18n {
i18n_construction :: Inline,
i18n_incoming :: Inline,
i18n_outgoing :: Inline
} deriving (Show)
enProveniencei18n :: Proveniencei18n
enProveniencei18n= Proveniencei18n {
i18n_construction = Str "Construction:",
i18n_incoming = Str "Sources:",
i18n_outgoing = Str "Used in:"
}
deProveniencei18n :: Proveniencei18n
deProveniencei18n = Proveniencei18n {
i18n_construction = Str "Erzeugung:",
i18n_incoming = Str "Quellen:",
i18n_outgoing = Str "Verwendet in:"
}
instance Default Proveniencei18n where
def = enProveniencei18n
renderStore :: Proveniencei18n -> VariableStore alt -> Block
renderStore i18n variables = let
nodelist = topsort (dependencyGraph variables) :: [Node]
renderIncoming i = let txt = maybe (show i) id (getShortname i variables)
in Link ("",["incoming"],[]) [Str txt] ('#':linknode i,txt)
renderOutgoing i = let txt = maybe (show i) id (getShortname i variables)
in Link ("",["outgoing"],[]) [Str txt] ('#':linknode i,txt)
renderVariable i = let
Just desc = getDescription i variables
how = foldMap (\(_,_,f) -> Set.singleton f) (inn (dependencyGraph variables) i)
sayhow = if Set.null how then [] else [Div ("",["edges"],[]) $ (Div ("",["provenienceKeyword"],[]) [Para [i18n_construction i18n]]):(Set.toList how)]
short = case shortname desc of
Nothing -> []
Just name -> [Header 3 ("",["shortname"],[]) [Str name]]
sources = case pre (dependencyGraph variables) i of
[] -> []
js@(_:_) -> [Div ("",["provenienceKeyword"],[]) [Para [i18n_incoming i18n]],BulletList $ map (pure . Plain . pure . renderIncoming) js]
sinks = case suc (dependencyGraph variables) i of
[] -> []
js@(_:_) -> [Div ("",["provenienceKeyword"],[]) [Para [i18n_outgoing i18n]],BulletList $ map (pure . Plain . pure . renderOutgoing) js]
in Div (linknode i,["variable"],[]) $ short++sources++sayhow++sinks++[
HorizontalRule,
Div ("",["description"],[]) [description desc],
Div ("",["valueRendering"],[]) [valueRendering desc]]
(n0,n1) = nodeRange (dependencyGraph variables)
in Div ("variables"++(showHex n0 ("To"++(showHex n1 ""))),["provenienceVariables"],[]) (map renderVariable nodelist)
renderSheet :: forall row sheet. (ToSheet row sheet, ToRow StaticCellValue row) =>
Proveniencei18n -> VariableStore (Seq row) -> sheet
renderSheet i18n variables = let
nodelist = topsort (dependencyGraph variables) :: [Node]
emptyRow = cellList ([] :: [StaticCellValue])
renderVariable :: Node -> Seq row
renderVariable i = let
Just desc = getDescription i variables
short = case shortname desc of
Nothing -> Seq.empty
Just name -> Seq.singleton (cellList [CellText name])
in short <> altRep desc <> Seq.singleton emptyRow
in chunksToSheet (fmap renderVariable nodelist)
changeLabel :: Node -> (VariableDesc alt -> VariableDesc alt) -> VariableStore alt -> VariableStore alt
changeLabel n f vs = vs {dependencyGraph = chl n f (dependencyGraph vs)} where
chl i f gr = let (mcntxt,gr') = match i gr in case mcntxt of
Nothing -> gr
Just (incoming,_,l,outgoing) -> (incoming,i,f l,outgoing) & gr'
varM :: Monad m => m a -> ProvenienceT alt m a
varM a = StateT $ \vs -> do
let i = nextFreeNode vs
v <- fmap (Variable i) a
let desc = VariableDesc {
shortname = Nothing,
description = Null,
valueRendering = Null,
altRep = error "no alternative representation supplied"
}
return (v,vs {dependencyGraph = insNode (i,desc) (dependencyGraph vs), nextFreeNode = succ i})
var :: Monad m => a -> ProvenienceT alt m a
var = varM . pure
inputM :: (Monad m, Representation a alt, DefaultRender a) => m a -> ProvenienceT alt m a
inputM a = do
x <- varM a
render x
return x
input :: (Monad m, Representation a alt, DefaultRender a) => a -> ProvenienceT alt m a
input a = do
x <- var a
render x
return x
func :: (Monad m, Default alt) => a -> Block -> ProvenienceT alt m a
func f what = do
v <- var f
v <? what
return v
infixl 3 <?
(<?) :: Variable a -> Block -> StoreUpdate
v <? about = modify' (\vs -> changeLabel (identifier v) (\desc -> desc {description=about}) vs)
named :: Variable a -> String -> StoreUpdate
v `named` name = modify' (\vs -> changeLabel (identifier v) (\desc -> desc {shortname = Just name}) vs)
infixl 4 <%>, <%%>
(<%>) :: Monad m => ProvenienceT alt m (a -> b) -> Variable a -> ProvenienceT alt m b
pf <%> x = ((fmap.fmap) (pure.) pf) <%%> x
(<%%>) :: Monad m => ProvenienceT alt m (a -> m b) -> Variable a -> ProvenienceT alt m b
pf <%%> x = do
f <- pf
StateT $ \store -> case getDescription (identifier f) store of
Nothing -> error ("Node "++(show (identifier f))++" not element of the store.")
Just desc -> let
modification = \vs -> vs {dependencyGraph = insEdge (identifier x, identifier f, description desc) (dependencyGraph vs)}
in do
y <- (value f) (value x)
return (f {value = y},modification store)
linkto :: Monad m => Variable a -> StateT (VariableStore alt) m Inline
linkto v = do
store <- get
let linktext = maybe (linkname v) id (getShortname (identifier v) store)
return $ Link nullAttr [Str linktext] ('#':linkname v,linktext)
runProvenienceT :: Monad m => ProvenienceT alt m a -> Node -> m ((a,VariableStore alt),Node)
runProvenienceT p n = fmap ((first value) &&& (nextFreeNode.snd)) (runStateT p st) where
st = VariableStore {
dependencyGraph = empty,
nextFreeNode = n}
sequenceProvenienceT :: (Traversable t, Monad m) => t (ProvenienceT alt m a) -> m (t (a,VariableStore alt))
sequenceProvenienceT ps = evalStateT (mapM (StateT . runProvenienceT) ps) 0 where
execProvenienceT :: Monad m => ProvenienceT alt m a -> Node -> m (VariableStore alt,Node)
execProvenienceT computation n = fmap (snd *** id) (runProvenienceT computation n)
execProvenience :: Provenience a -> Node -> (VariableStore (),Node)
execProvenience computation n = runIdentity (execProvenienceT computation n)
evalProvenienceT :: Monad m => ProvenienceT alt m a -> m a
evalProvenienceT computation = fmap (fst.fst) (runProvenienceT computation 0)
evalProvenience :: Provenience a -> a
evalProvenience computation = runIdentity (evalProvenienceT computation)