UidGen.hs

{- This file is part of language-kort.
 -
 - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Language.Kort.UidGen
    ( stmtHasGens
    , docHasGens
    , generateResources
    , generateResourcesIO
    , sweepGenerators
    )
where

import Control.Monad (liftM)
import Data.ByteString.Char8 (unpack)
import Data.List (mapAccumL, nub)
import Data.Monoid
import qualified Data.Smaoin as S
import Language.Kort.Types
import System.Random

-- | Check if a statement has generators.
stmtHasGens :: Statement -> Bool
stmtHasGens (Statement i r e) = isGen i || isGen r || any hasGen e
    where
    isGen (Uid _) = False
    isGen _       = True
    hasGen (Resource r) = isGen r
    hasGen (Value s r)  = isGen r

-- | Check if a document has generators.
docHasGens :: Document -> Bool
docHasGens = any p
    where
    p (Right s) = stmtHasGens s
    p (Left _)  = False

-- Make a list of unique generator labels and the number of unlabeled
-- generators in the document.
collectGens :: Document -> ([String], Int)
collectGens ls = k $ mconcat [h i r e | Right (Statement i r e) <- ls]
    where
    p UGenerator = True
    p _          = False
    m (Resource r) = r
    m (Value s r)  = r
    f rs = ([s | LGenerator s <- rs], Sum $ length $ filter p rs)
    g els = f $ map m els
    h i r e = g $ Resource i : Resource r : e
    k (l, n) = (nub l, getSum n)

-- Generate a list of a given length containing fresh new unique Uids.
genUids :: RandomGen g => Int -> g -> ([String], g)
genUids n = f n []
    where
    f 0 ss g = (ss, g)
    f n ss g =
        let (s, g') = (\ (S.Resource r, g) -> (unpack r, g)) $ random g
        in  f (n - 1) (s:ss) g'

-- Return a Uid for a resource - either the existing one or a newly generated
-- one if a generator is given
genResOne :: UidMap -> Resource -> (UidMap, String)
genResOne um (Uid s)              = (um, s)
genResOne (lu, uu) (LGenerator s) =
    case lookup s lu of
        Just u  -> ((lu, uu), u)
        Nothing -> error "genResOne impl error"
genResOne (lu, uu:uus) UGenerator = ((lu, uus), uu)
genResOne _ _ = error "genResOne impl error"

-- Apply function to first element of pair
applyFst :: (a -> c) -> (a, b) -> (c, b)
applyFst f (x, y) = (f x, y)

-- Apply function to second element of pair
applySnd :: (b -> c) -> (a, b) -> (a, c)
applySnd f (x, y) = (x, f y)

-- Replace generators with Uids in a single statement
genResStmt :: UidMap -> Statement -> (UidMap, Statement)
genResStmt um (Statement i r e) = (um', Statement i' r' e')
    where
    (umi, i') = applySnd Uid $ genResOne um i
    (umr, r') = applySnd Uid $ genResOne umi r
    f um (Resource r) = applySnd (Resource . Uid) $ genResOne um r
    f um (Value s r)  = applySnd (Value s . Uid) $ genResOne um r
    (um', e') = mapAccumL f umr e

-- Create Uid map with generated Uids for given document
makeMap :: RandomGen g => Document -> g -> (UidMap, g)
makeMap doc g =
    let (ls, n) = collectGens doc
        (lu, g') = genUids (length ls) g
        (uu, g'') = genUids n g'
    in  ((zip ls lu, uu), g'')

-- | Replace generators with newly generated unique resources.
generateResources :: RandomGen g => Document -> g -> (Document, g)
generateResources doc g =
    let f m l@(Left _)   = (m, l)
        f m (Right stmt) = applySnd Right $ genResStmt m stmt
        (m, g') = makeMap doc g
    in  (snd $ mapAccumL f m doc, g')

-- | Like 'generateResources', but uses specifically the global system random
-- generator.
generateResourcesIO :: Document -> IO Document
generateResourcesIO doc = liftM (fst . generateResources doc) getStdGen

-- Return a Uid for a resource - either the existing one or a blank one if a
-- generator is given
cleanGensOne :: Resource -> Resource
cleanGensOne r@(Uid _)      = r
cleanGensOne (LGenerator s) = Uid "?"
cleanGensOne UGenerator     = Uid "?"

-- Replace generators with dummy Uids in a single statement
cleanGensStmt :: Statement -> Statement
cleanGensStmt (Statement i r e) =
    Statement (cleanGensOne i) (cleanGensOne r) (map f e)
    where
    f (Resource r) = Resource $ cleanGensOne r
    f (Value s r)  = Value s $ cleanGensOne r

-- | Replace generators with dummy resource Uids (ASCII question marks).
sweepGenerators :: Document -> Document
sweepGenerators = map f
    where
    f l@(Left _) = l
    f (Right s)  = Right $ cleanGensStmt s