
-- | Tools to build and access an AO dictionary.
module AO.Dict
    ( AODef, AODictMap, AODict
    , buildAODict, cleanAODict, emptyAODict
    , readAODict, updateAODict, unsafeUpdateAODict
    , AODictIssue(..)
    ) where

import Control.Monad ((>=>))
import Data.Maybe (fromJust)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as Set
import AO.InnerDict
import AO.Code

-- | An AO definition is a trivial pairing of a word with the AO code
-- that is inlined wherever the word is used. In practice, we want some
-- extra metadata with each definition (e.g. source location).
type AODef meta = (Word,(AO_Code,meta))

-- | A dictionary map is simply a map formed of AO definitions.
type AODictMap meta = M.Map Word (AO_Code,meta)

-- | Access the clean definitions within an AO dictionary.
readAODict :: AODict meta -> AODictMap meta
readAODict (AODict d) = d

-- | update metadata for a word (if it exists)
updateAODict :: (AO_Code -> meta -> meta) -> Word -> AODict meta -> AODict meta
updateAODict fn w (AODict d) = case M.lookup w d of
    Nothing -> (AODict d)
    Just (code,meta) -> 
        let meta' = fn code meta in
        AODict (M.insert w (code,meta') d)

-- | allow arbitrary manipulations if we really want them
-- but at least mark them clearly. Try to use safely - i.e.
-- adding annotations, inlining and partial evaluations, etc.
unsafeUpdateAODict :: (AODictMap m -> AODictMap m) -> (AODict m -> AODict m)
unsafeUpdateAODict f (AODict d) = AODict (f d)

-- | useful for initializations
emptyAODict :: AODict meta
emptyAODict = AODict (M.empty)

-- | to report problems with a dictionary while cleaning it up.
--
-- Override: multiple definitions are provided for a word, in the
-- order given. The last definition in this list is kept in the
-- dictionary, unless there's some other issue with it.
--
-- Cycle: a word is transitively part of a cycle, and thus its
-- definition cannot be fully inlined (as per AO semantics). Where
-- conventional languages use recursion, AO uses explicit fixpoint.
-- A good fixpoint combinator is: %r [%^'wol] %rwo^'wol 
--
-- Cycles are removed from the dictionary after being recognized,
-- such that any given word is recognized as part of at most one 
-- cycle. This may result in missing definition warnings.
-- 
-- Missing: a definition uses words that are not part of the
-- dictionary. All such definitions are removed from the dictionary.
-- 
data AODictIssue meta
    = AODefOverride Word [(AO_Code,meta)] -- multiple definitions for one word.
    | AODefCycle [AODef meta]             -- a cycle of words 
    | AODefMissing (AODef meta) [Word]    -- definition is missing words in list

-- a warning capability
type ReportIssue m meta = AODictIssue meta -> m ()

-- | given a list of definitions, produce a 'clean' dictionary (no cycles, 
-- no incompletely defined words) and also generate some warnings or errors.
buildAODict :: (Monad m) => ReportIssue m meta -> [AODef meta] -> m (AODict meta)
buildAODict warn = getFinalDefs warn >=> cleanAODict warn

-- build a map and report overrides 
getFinalDefs :: (Monad m) => ReportIssue m meta -> [AODef meta] -> m (AODictMap meta)
getFinalDefs warn defs =
    let mdict = L.foldl mmins M.empty defs in -- (word,(cm,[cm]))
    let dictOfFinalDefs = fmap fst mdict in -- (word,cm) 
    let lOverrides = M.toList $ fmap (L.reverse . uncurry (:)) 
                              $ M.filter (not . null . snd) mdict 
    in
    mapM_ (warn . uncurry AODefOverride) lOverrides >>
    return dictOfFinalDefs

mmins :: (Ord k) => M.Map k (a,[a]) -> (k,a) -> M.Map k (a,[a])
mmins d (k,a) = M.alter (mmcons a) k d where
    mmcons a0 Nothing = Just (a0,[])
    mmcons a0 (Just (a1,as)) = Just (a0,(a1:as))

-- | cleanup a map by removing words with cyclic or incomplete definitions
cleanAODict :: (Monad m) => ReportIssue m meta -> AODictMap meta -> m (AODict meta) 
cleanAODict warn = clearCycles warn >=> clearMissing warn >=> return . AODict

clearCycles :: (Monad m) => ReportIssue m meta -> AODictMap meta -> m (AODictMap meta) 
clearCycles warn d0 = emitErrors >> return cycleFree where
    g0 = fmap (aoWords . fst) d0 -- M.Map Word [Word]
    cycles = detectCycles g0 -- [[Word]]
    cycleFree = L.foldr M.delete d0 (L.concat cycles)
    emitErrors = mapM_ reportCycle cycles
    reportCycle = warn . AODefCycle . fmap getData 
    getData w = (w, fromJust (M.lookup w d0)) -- recover def & meta
        -- by nature, any word in a cycle must be defined
        -- so 'fromJust' is safe here

-- detect cycles in an abstract directed graph 
-- using a depth-first search
detectCycles :: (Ord v) => M.Map v [v] -> [[v]]
detectCycles = deforest where
    deforest g = case M.minViewWithKey g of
        Nothing -> []
        Just ((v0,vs),_) -> 
            let (visited, cycles) = dfs g [v0] [v0] vs in
            let g' = L.foldr M.delete g visited in
            cycles ++ deforest g'
    dfs _ cx _ [] = (cx, [])
    dfs g cx p (v:vs) = 
        case (L.elemIndex v p) of
            Nothing -> -- no loop; may need to visit 'v'
                if L.elem v cx then dfs g cx p vs else 
                let (cxd,cycd) = dfs g (v:cx) (v:p) (edgesFrom g v) in
                let (cxw,cycw) = dfs g cxd p vs in
                (cxw, cycd ++ cycw)
            Just n -> -- loop found; 'v' necessarily has been visited 
                let cyc0 = L.reverse (L.take (n + 1) p) in
                let (cxw,cycw) = dfs g cx p vs in
                (cxw,(cyc0:cycw))
    edgesFrom g v = maybe [] id $ M.lookup v g

-- keep only words whose definitions are transitively fully defined
clearMissing :: (Monad m) => ReportIssue m meta -> AODictMap meta -> m (AODictMap meta) 
clearMissing warn d0 = emitErrors >> return fullyDefined where
    g0 = fmap (aoWords . fst) d0 -- 
    mwMap = incompleteWords g0
    fullyDefined = L.foldr M.delete d0 (M.keys mwMap)
    emitErrors = mapM_ reportError (M.toList mwMap)
    reportError = warn . mkWarning
    mkWarning (w,mws) = -- w is in dictionary; mws aren't
        let defW = fromJust (M.lookup w d0) in
        AODefMissing (w,defW) mws

-- find incomplete words based on missing transitive dependencies
-- the result is a map of word -> missing words.
incompleteWords :: (Ord w) => M.Map w [w] -> M.Map w [w]
incompleteWords dict = dictMW where
    (dictMW, _okSet) = L.foldl cw (M.empty, Set.empty) (M.keys dict)
    cw r w = 
        if (M.member w (fst r) || Set.member w (snd r)) then r else
        case M.lookup w dict of
            Nothing -> r -- w is missing word; will capture in 'mdeps' below
            Just deps ->
                let (dmw, dok) = L.foldl cw r deps in
                let mdeps = L.filter (`Set.notMember` dok) deps in
                if null mdeps 
                    then (dmw, Set.insert w dok) -- add word to OK set
                    else (M.insert w mdeps dmw, dok) -- add word to missing words map

