module Development.Duplo.JavaScript.Order where
import Control.Applicative ((<$>))
import Control.Exception (throw)
import Control.Lens (makeLenses, ix)
import Control.Lens.Operators
import Control.Monad (liftM, when, void)
import Control.Monad.State.Lazy (get, put, state, execState)
import Control.Monad.Writer.Lazy (Writer, tell, runWriter)
import Data.Function (on)
import Data.List (findIndex, sortBy, nubBy)
import Data.Maybe (isJust, fromJust, fromMaybe)
import Development.Duplo.Types.JavaScript
import Language.JavaScript.Parser (JSNode(..), Node(..), TokenPosn(..))
makeLenses ''Module
order :: JSNode -> JSNode
order jsNode =
NN $ JSSourceElementsTop $ naNodes ++ aNodesWithSep
where
separator = NT (JSLiteral ";") (TokenPn 0 0 0) []
(naNodes, aNodes) = runWriter $ extract jsNode
orderedANodes = _node <$> reorder aNodes
aNodesWithSep = concat $ fmap (\n -> [n, separator]) orderedANodes
extract :: JSNode -> Writer [Module] [JSNode]
extract (NN (JSSourceElementsTop jsElements)) = mapM extract' jsElements
extract element = throw $ LanguageJavaScriptException element
extract' :: JSNode -> Writer [Module] JSNode
extract' jsNode@(NN (JSExpression (NT (JSIdentifier "define") _ _:args:_))) = do
tell [makeModule jsNode args]
return $ NT (JSIdentifier "") (TokenPn 0 0 0) []
extract' jsNode = return jsNode
makeModule :: JSNode
-> JSNode
-> Module
makeModule rootNode argNode =
Module moduleName deps rootNode Nothing
where
(NN (JSArguments _ argNTs _)) = argNode
(nameNT:_:depsNT:_) = argNTs
(NT (JSStringLiteral _ moduleName) _ _) = nameNT
(NN (JSArrayLiteral _ depsNodes _)) = depsNT
deps = map fromJust $ filter isJust $ map stringLiteralNT depsNodes
stringLiteralNT :: JSNode -> Maybe String
stringLiteralNT (NT (JSStringLiteral _ string) _ _) = Just string
stringLiteralNT _ = Nothing
reorder :: [Module] -> [Module]
reorder mods = nubbed
where
scored = execState computeScores mods
filtered = filter withScore scored
sorted = sortBy byDepScore filtered
nubbed = reverse $ nubBy ((==) `on` _name) $ reverse sorted
withScore :: Module -> Bool
withScore aMod = case _score aMod of
Just _ -> True
Nothing -> False
byDepScore :: Module -> Module -> Ordering
byDepScore a b = compare (_score a) (_score b)
computeScores :: OrderedModules [DepScore]
computeScores = do
mods <- get
mapM (getDepScore []) $ fmap _name mods
getDepScore :: [ModuleName] -> ModuleName -> OrderedModules DepScore
getDepScore history modName = do
let history' = modName : history
void $ when (modName `elem` history)
$ throw $ CircularDependencyException $ reverse history'
mods <- get
let maybeIndex = findIndex ((modName ==) . _name) mods
let index = fromMaybe (throw $ ModuleNotFoundException modName) maybeIndex
let aMod = fromJust $ mods ^? ix index
let modDeps = _dependencies aMod
depScore <- case _score aMod of
Just modScore -> state $ const (modScore, mods)
Nothing -> getDepScore' history' modDeps
let newMod = aMod & score .~ Just depScore
let newMods = take index mods ++ [newMod] ++ drop (index + 1) mods
put newMods
return depScore
getDepScore' :: [ModuleName] -> [ModuleName] -> OrderedModules DepScore
getDepScore' history modNames =
liftM ((1 +) . sum) $ mapM (getDepScore history) modNames