111 lines
2.9 KiB
Haskell
111 lines
2.9 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Forest.Node
|
|
(
|
|
-- * Node
|
|
NodeId
|
|
, Node(..)
|
|
, newNode
|
|
, emptyNode
|
|
, hasChildren
|
|
, mapChildren
|
|
, applyId
|
|
, applyPath
|
|
, replaceAt
|
|
-- * Path
|
|
, Path(..)
|
|
, localPath
|
|
, isLocalPath
|
|
, isValidPath
|
|
, narrowPath
|
|
, narrowSet
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Data.Aeson
|
|
import Data.Char
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Text as T
|
|
import GHC.Generics
|
|
|
|
{- Node -}
|
|
|
|
type NodeId = T.Text
|
|
|
|
data Node = Node
|
|
{ nodeText :: !T.Text
|
|
, nodeEdit :: !Bool
|
|
, nodeDelete :: !Bool
|
|
, nodeReply :: !Bool
|
|
, nodeAct :: !Bool
|
|
, nodeChildren :: !(Map.Map NodeId Node)
|
|
} deriving (Show, Generic)
|
|
|
|
nodeOptions :: Options
|
|
nodeOptions = defaultOptions{fieldLabelModifier = map toLower . drop 4}
|
|
|
|
instance ToJSON Node where
|
|
toJSON = genericToJSON nodeOptions
|
|
toEncoding = genericToEncoding nodeOptions
|
|
|
|
instance FromJSON Node where
|
|
parseJSON = genericParseJSON nodeOptions
|
|
|
|
newNode :: String -> T.Text -> [Node] -> Node
|
|
newNode flags text children =
|
|
let edit = 'e' `elem` flags
|
|
delete = 'd' `elem` flags
|
|
reply = 'r' `elem` flags
|
|
act = 'a' `elem` flags
|
|
digits = length $ show $ length children
|
|
formatId :: Integer -> T.Text
|
|
formatId = T.justifyRight digits '0' . T.pack . show
|
|
pairedChildren = zip (map formatId [0..]) children
|
|
in Node text edit delete reply act $ Map.fromList pairedChildren
|
|
|
|
emptyNode :: String -> T.Text -> Node
|
|
emptyNode flags text = newNode flags text []
|
|
|
|
hasChildren :: Node -> Bool
|
|
hasChildren = not . Map.null . nodeChildren
|
|
|
|
mapChildren :: (NodeId -> Node -> a) -> Node -> [a]
|
|
mapChildren f node = map (uncurry f) $ Map.toAscList $ nodeChildren node
|
|
|
|
applyId :: NodeId -> Node -> Maybe Node
|
|
applyId nodeId node = nodeChildren node Map.!? nodeId
|
|
|
|
applyPath :: Path -> Node -> Maybe Node
|
|
applyPath (Path ids) node = foldM (flip applyId) node ids
|
|
|
|
replaceAt :: Node -> Path -> Node -> Node
|
|
replaceAt childNode (Path []) _ = childNode
|
|
replaceAt childNode (Path (x:xs)) node =
|
|
let newChildren = Map.adjust (replaceAt childNode $ Path xs) x $ nodeChildren node
|
|
in node{nodeChildren = newChildren}
|
|
|
|
{- Path -}
|
|
|
|
newtype Path = Path
|
|
{ pathElements :: [NodeId]
|
|
} deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
|
|
|
|
localPath :: Path
|
|
localPath = Path []
|
|
|
|
isLocalPath :: Path -> Bool
|
|
isLocalPath = (== localPath)
|
|
|
|
isValidPath :: Node -> Path -> Bool
|
|
isValidPath node path = isJust $ applyPath path node
|
|
|
|
narrowPath :: NodeId -> Path -> Maybe Path
|
|
narrowPath x (Path (y:ys))
|
|
| x == y = Just (Path ys)
|
|
narrowPath _ _ = Nothing
|
|
|
|
narrowSet :: NodeId -> Set.Set Path -> Set.Set Path
|
|
narrowSet x s = Set.fromList [Path ys | Path (y:ys) <- Set.toList s, x == y]
|