60 lines
1.9 KiB
Haskell
60 lines
1.9 KiB
Haskell
module Stream (
|
|
Stream(..)
|
|
, fromList
|
|
, infinite
|
|
, merge
|
|
, showStream
|
|
) where
|
|
|
|
import Data.List (intercalate)
|
|
|
|
data Stream a = Stream [(a, Stream a)] deriving Show
|
|
|
|
instance Monoid (Stream a) where
|
|
mempty = fromList []
|
|
mappend (Stream []) b = b
|
|
mappend (Stream pairs) b = Stream $ (\(a, stream) -> (a, stream `mappend` b)) <$> pairs
|
|
|
|
fromList :: [a] -> Stream a
|
|
fromList [] = Stream []
|
|
fromList (pair:pairs) = Stream [(pair, fromList pairs)]
|
|
|
|
infinite :: a -> Stream a
|
|
infinite a = Stream [(a, infinite a)]
|
|
|
|
merge :: Eq a => Stream a -> Stream a -> Stream a
|
|
merge (Stream aPairs) (Stream bPairs) = Stream $ foldl mergeOrAdd aPairs bPairs
|
|
where
|
|
openAt _ l [] = (l, [])
|
|
openAt p up l@(x:xs) = if p x then (up, l) else openAt p (x:up) xs
|
|
zipUp ([], l) = l
|
|
zipUp (x:xs, l) = zipUp (xs, x:l)
|
|
mergeOrAdd accumulator (b, bStream) = zipUp $
|
|
case openAt ((== b) . fst) [] accumulator of
|
|
(up, []) -> (up, [(b, bStream)])
|
|
(up, (x, xStream):down) -> (up, (x, merge xStream bStream):down)
|
|
|
|
showStream :: Show a => Stream a -> String
|
|
showStream = intercalate "\n" . getLines
|
|
|
|
getLines :: Show a => Stream a -> [String]
|
|
getLines (Stream []) = ["╼"]
|
|
getLines (Stream [(a, stream)]) = showBlock '─' (a, stream)
|
|
getLines (Stream ((a, stream):pairs)) = concat $
|
|
showBlock '┬' (a, stream) : showBlocks pairs
|
|
where
|
|
showBlocks [] = []
|
|
showBlocks [(a, stream)] = [showBlock '╰' (a, stream)]
|
|
showBlocks ((a, stream):pairs) =
|
|
showBlock '├' (a, stream) : showBlocks pairs
|
|
|
|
showBlock :: Show a => Char -> (a, Stream a) -> [String]
|
|
showBlock connectingChar (a, stream) =
|
|
case getLines stream of
|
|
[] -> []
|
|
firstLine:otherLines -> (prefix ++ firstLine) : (pad <$> otherLines)
|
|
where
|
|
connect = ((if connectingChar `elem` "├┬" then '│' else ' '):)
|
|
prefix = connectingChar : " " ++ show a ++ " "
|
|
pad = connect . (take (length prefix - 1) (repeat ' ') ++)
|