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
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
docHasGens :: Document -> Bool
docHasGens = any p
where
p (Right s) = stmtHasGens s
p (Left _) = False
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)
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'
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"
applyFst :: (a -> c) -> (a, b) -> (c, b)
applyFst f (x, y) = (f x, y)
applySnd :: (b -> c) -> (a, b) -> (a, c)
applySnd f (x, y) = (x, f y)
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
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'')
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')
generateResourcesIO :: Document -> IO Document
generateResourcesIO doc = liftM (fst . generateResources doc) getStdGen
cleanGensOne :: Resource -> Resource
cleanGensOne r@(Uid _) = r
cleanGensOne (LGenerator s) = Uid "?"
cleanGensOne UGenerator = Uid "?"
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
sweepGenerators :: Document -> Document
sweepGenerators = map f
where
f l@(Left _) = l
f (Right s) = Right $ cleanGensStmt s