module Game.Goatee.Lib.Tree (
Collection(..), CollectionWithDeepEquality(..),
Node(..), NodeWithDeepEquality(..),
emptyNode, rootNode,
findProperty, findProperty', findPropertyValue, findPropertyValue',
addProperty, addChild, addChildAt, deleteChildAt,
validateNode,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, unless, when)
import Control.Monad.Writer (Writer, execWriter, tell)
import Data.Function (on)
import Data.List (find, groupBy, intercalate, nub, sortBy)
import Data.Ord (comparing)
import Data.Version (showVersion)
import Game.Goatee.App (applicationName)
import Game.Goatee.Common
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.Types
import Paths_goatee (version)
data Collection = Collection
{ collectionTrees :: [Node]
} deriving (Show)
newtype CollectionWithDeepEquality = CollectionWithDeepEquality
{ collectionWithDeepEquality :: Collection
} deriving (Show)
instance Eq CollectionWithDeepEquality where
(==) = (==) `on` map NodeWithDeepEquality . collectionTrees . collectionWithDeepEquality
data Node = Node
{ nodeProperties :: [Property]
, nodeChildren :: [Node]
} deriving (Show)
newtype NodeWithDeepEquality = NodeWithDeepEquality { nodeWithDeepEquality :: Node }
instance Eq NodeWithDeepEquality where
node1 == node2 =
let n1 = nodeWithDeepEquality node1
n2 = nodeWithDeepEquality node2
in propertiesSorted n1 == propertiesSorted n2 &&
deepChildren n1 == deepChildren n2
where propertiesSorted = sortBy (comparing show) . nodeProperties
deepChildren = map NodeWithDeepEquality . nodeChildren
emptyNode :: Node
emptyNode = Node { nodeProperties = [], nodeChildren = [] }
rootNode :: Maybe (Int, Int) -> Node
rootNode maybeSize =
let props = FF 4 :
GM 1 :
AP (toSimpleText applicationName)
(toSimpleText $ showVersion version) :
maybe [] ((:[]) . uncurry SZ) maybeSize
in Node { nodeProperties = props
, nodeChildren = []
}
findProperty :: Descriptor a => a -> Node -> Maybe Property
findProperty descriptor node = findProperty' descriptor $ nodeProperties node
findProperty' :: Descriptor a => a -> [Property] -> Maybe Property
findProperty' = find . propertyPredicate
findPropertyValue :: ValuedDescriptor v a => a -> Node -> Maybe v
findPropertyValue descriptor node = propertyValue descriptor <$> findProperty descriptor node
findPropertyValue' :: ValuedDescriptor v a => a -> [Property] -> Maybe v
findPropertyValue' descriptor properties =
propertyValue descriptor <$> findProperty' descriptor properties
addProperty :: Property -> Node -> Node
addProperty prop node = node { nodeProperties = nodeProperties node ++ [prop] }
addChild :: Node -> Node -> Node
addChild child node = node { nodeChildren = nodeChildren node ++ [child] }
addChildAt :: Int -> Node -> Node -> Node
addChildAt index child node =
let (before, after) = splitAt index $ nodeChildren node
in node { nodeChildren = before ++ child:after }
deleteChildAt :: Int -> Node -> Node
deleteChildAt index node =
let children = nodeChildren node
in if index < 0 || index > length children
then node
else node { nodeChildren = listDeleteAt index children }
validateNode :: Bool -> Bool -> Node -> [String]
validateNode isRoot _ node = execWriter $ do
let props = nodeProperties node
let propTypes = nub $ map propertyType $ nodeProperties node
when (MoveProperty `elem` propTypes && SetupProperty `elem` propTypes) $
tell ["Node contains move and setup properties."]
let rootProps = filter ((RootProperty ==) . propertyType) props
when (not isRoot && not (null rootProps)) $
tell $ map (\p -> "Root property found on non-root node: " ++
show p ++ ".")
rootProps
validateNodeDuplicates props getMarkedCoords $ \group ->
tell ["Coordinate " ++ show (fst $ head group) ++
" is specified multiple times in properties " ++
intercalate ", " (map snd group) ++ "."]
where getMarkedCoords (CR cs) = tagMarkedCoords cs "CR"
getMarkedCoords (MA cs) = tagMarkedCoords cs "MA"
getMarkedCoords (SL cs) = tagMarkedCoords cs "SL"
getMarkedCoords (SQ cs) = tagMarkedCoords cs "SQ"
getMarkedCoords (TR cs) = tagMarkedCoords cs "TR"
getMarkedCoords _ = []
tagMarkedCoords cs tag = map (\x -> (x, tag)) $ expandCoordList cs
validateNodeDuplicates :: (Eq v, Ord v)
=> [Property]
-> (Property -> [(v, t)])
-> ([(v, t)] -> Writer [String] ())
-> Writer [String] ()
validateNodeDuplicates props getTaggedElts errAction =
let groups = groupBy ((==) `on` fst) $
sortBy (comparing fst) $
concatMap getTaggedElts props
in forM_ groups $ \group ->
unless (null $ tail group) $
errAction group