{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms #-}
module Data.Layout where
import qualified Prelude as P
import Prologue hiding ((:>), Empty, Bounded, div, simple, concat, putStr, swapped, length, putStrLn, take, drop, nested, lines)
import qualified Control.Monad.State.Layered as State
import qualified Data.Foldable as Foldable
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Builder as Text
import Data.Text.Terminal hiding (plain)
import Data.Sequence.Class
betweenWith :: (a -> a -> a) -> a -> a -> a -> a
betweenWith f l r m = l `f` m `f` r
surroundedWith :: (a -> a -> a) -> a -> a -> a -> a
surroundedWith f m l r = betweenWith f l r m
between :: Semigroup a => a -> a -> a -> a
between = betweenWith (<>)
between' :: Semigroup a => a -> a -> a
between' a = between a a
space :: IsString a => a
space = " "
parensed, bracked, braced, chevroned, spaced, quoted, singleQuoted, backticked :: (Semigroup a, IsString a) => a -> a
parensed = between "(" ")"
bracked = between "[" "]"
braced = between "{" "}"
chevroned = between "<" ">"
spaced = between' " "
quoted = between' "\""
singleQuoted = between' "'"
backticked = between' "`"
enumerateWith :: (Monoid a, Foldable f) => a -> a -> f a -> a
enumerateWith sep lastSep els = case Foldable.toList els of
[] -> mempty
ss -> intercalate sep (unsafeInit ss) <> lastSep <> unsafeLast ss
enumerateAlt, enumerateSeq :: (Monoid a, IsString a, Foldable f) => f a -> a
enumerateAlt = enumerateWith ", " " or "
enumerateSeq = enumerateWith ", " " and "
newtype Delta = Delta Word64 deriving (Generic, Show, Num, Ord, Eq, Enum)
makeLenses ''Delta
instance Convertible' a Word64 => Convertible a Delta where convert = wrap . convert'
instance Convertible' Word64 a => Convertible Delta a where convert = convert' . unwrap
instance NFData Delta
instance Default Delta where def = 0
instance Mempty Delta where mempty = def
instance Semigroup Delta where (<>) = (+)
class ElemBuilderT t m a where plainT :: m a -> t m a
class ElemBuilder m a where plain :: a -> m a
instance {-# OVERLAPPABLE #-} (ElemBuilder m a, ElemBuilderT t m a)
=> ElemBuilder (t m) a where plain = plainT . plain
instance ElemBuilder Identity a where plain = return
class RenderT t m a where renderT :: t m a -> m a
class Render m a where render :: m a -> a
nested :: m a -> m a
instance {-# OVERLAPPABLE #-} (RenderT t m a, Render m a, ElemBuilderT t m a)
=> Render (t m) a where render = render . renderT
nested = plainT . renderT
instance Render Identity a where render = runIdentity
nested = id
phantom :: (ElemBuilder t a, Mempty a) => t a
phantom = plain mempty
data Bounds = Bounds { _width :: !Delta
, _height :: !Delta
} deriving (Show)
data Bounded a = Bounded { __bounds :: Bounds
, __elem :: a
} deriving (Show, Functor, Traversable, Foldable)
makeClassy ''Bounds
makeLenses ''Bounded
class Measurable a where
measure :: a -> Bounds
instance Measurable (Bounded a) where
measure = view bounds
bounded :: Lens (Bounded a) (Bounded b) a b
bounded = bounded_elem
unbound :: Bounded a -> a
unbound = view bounded
instance Mempty a => Mempty (Bounded a) where
mempty = Bounded mempty mempty
instance Mempty Bounds where mempty = Bounds mempty mempty
instance HasBounds (Bounded a) where bounds = bounded_bounds
instance Concatenable Bounds where
concat t (Bounds w h) (Bounds w' h') = case t of
Horizontal -> Bounds (w <> w') (max h h')
Vertical -> Bounds (max w w') (h <> h')
data Dir = Vertical
| Horizontal
deriving (Show)
data CartTree t m a = Empty
| Plain !(m a)
| Concat !Dir !(t m a) !(t m a)
deriving (Show, Functor, Traversable, Foldable)
class Concatenable a where
concat :: Dir -> a -> a -> a
instance Concatenable a => Concatenable (Identity a) where
concat d l r = Identity $ concat d (runIdentity l) (runIdentity r)
hcat, vcat :: Concatenable a => a -> a -> a
hcat = concat Horizontal
vcat = concat Vertical
infixr 6 </>
(</>) :: Concatenable a => a -> a -> a
(</>) = vcat
instance Mempty (CartTree t m a) where
mempty = Empty
instance Convertible2' (CartTree t) t => Semigroup (CartTree t m a) where
Empty <> a = a
a <> Empty = a
a <> b = Concat Horizontal (convert2' a) (convert2' b)
instance Convertible2' (CartTree t) t => Concatenable (CartTree t m a) where
concat d a b = Concat d (convert2' a) (convert2' b)
instance Convertible2' (CartTree t) t => P.Monoid (CartTree t m a) where
mempty = mempty
mappend = (<>)
class Spacing a where
spacing :: Bounds -> a
hspacing, vspacing :: (ElemBuilder t a, Spacing a) => Delta -> t a
hspacing = plain . spacing . flip Bounds 1
vspacing = plain . spacing . Bounds 1
infixr 6 <+>
(<+>) :: (ElemBuilder t a, Semigroup (t a), Spacing a) => t a -> t a -> t a
(<+>) = mappendWith $ hspacing 1
infixr 6 <//>
infixr 6 <///>
infixr 6 <////>
(<//>), (<///>), (<////>) :: (Concatenable (t a), ElemBuilder t a, Spacing a) => t a -> t a -> t a
a <//> b = vcat a (vcat (vspacing 1) b)
a <///> b = vcat a (vcat (vspacing 2) b)
a <////> b = vcat a (vcat (vspacing 3) b)
data LineBlock a = LineBlock { __bounds :: Bounds, _lines :: [a] } deriving (Show, Functor, Foldable, Traversable)
makeLenses ''LineBlock
renderLineBlock :: (IsString a, Monoid a, Item a ~ Char, FiniteSequence a) => LineBlock a -> a
renderLineBlock = intercalate "\n" . fmap stripEnd . view lines
concatLineBlock :: (IsString a, Monoid a) => LineBlock a -> a
concatLineBlock = intercalate "\n" . view lines
instance HasBounds (LineBlock a) where bounds = lineBlock_bounds
instance Measurable (LineBlock a) where measure = view bounds
instance Mempty (LineBlock a) where mempty = LineBlock mempty mempty
instance GenLineBlockConcatCtx a => Semigroup (LineBlock a) where (<>) = concat Horizontal
instance GenLineBlockConcatCtx a => P.Monoid (LineBlock a) where
mempty = mempty
mappend = (<>)
type GenLineBlockConcatCtx a = (Convertible String a, Monoid a)
instance GenLineBlockConcatCtx a => Concatenable (LineBlock a) where
concat d l r = LineBlock nbs newtb where
lbs = measure l
rbs = measure r
maxw = max (lbs ^. width) (rbs ^. width)
maxh = max (lbs ^. height) (rbs ^. height)
relw = width %~ (maxw -)
relh = height %~ (maxh -)
eqw t = zipWith (<>) (t ^. lines) (spacing (relw $ t ^. bounds) ^. lines)
eqh t = t ^. lines <> spacing (relh $ t ^. bounds) ^. lines
nbs = concat d lbs rbs
newtb = case d of
Horizontal -> zipWith (<>) (eqh l) (eqh r)
Vertical -> eqw l <> eqw r
instance (IsString a, Measurable a) => IsString (LineBlock a) where
fromString s = LineBlock (measure a) $ pure a where a = fromString s
instance (Convertible' Text a, Measurable a) => Convertible Text (LineBlock a) where
convert s = LineBlock (measure a) $ pure a where a = convert' s
instance (Convertible String a, Mempty a) => Spacing (LineBlock a) where
spacing b@(Bounds w h) = LineBlock b lines where
lines = replicate h $ convert (replicate w ' ')
type BlockBuilder = BlockBuilderT Identity
newtype BlockBuilderT m a = BlockBuilderT (CartTree BlockBuilderT m a) deriving (Show, Functor, Traversable, Foldable, Mempty, Semigroup, P.Monoid, Concatenable)
instance ElemBuilderT BlockBuilderT m a where
plainT = BlockBuilderT . Plain
instance (Mempty (m a), Concatenable (m a)) => RenderT BlockBuilderT m a where
renderT (BlockBuilderT t) = case t of
Plain a -> a
Empty -> mempty
Concat d l r -> concat d (renderT l) (renderT r)
append :: BlockBuilder a -> BlockBuilder a -> BlockBuilder a
append a block@(BlockBuilderT b) = case b of
Concat d l r -> BlockBuilderT $ Concat d l (append a r)
_ -> block <> a
prepend :: BlockBuilder a -> BlockBuilder a -> BlockBuilder a
prepend a block@(BlockBuilderT b) = case b of
Concat d l r -> BlockBuilderT $ Concat d (prepend a l) r
_ -> a <> block
instance Convertible2 (CartTree BlockBuilderT) BlockBuilderT where convert2 = wrap
instance (ElemBuilder m a, IsString a) => IsString (BlockBuilderT m a) where fromString = plain . fromString
instance (ElemBuilder m a, Convertible' Text a) => Convertible Text (BlockBuilderT m a) where convert = plain . convert'
instance (ElemBuilder m a, Convertible' Text a) => Convertible String (BlockBuilderT m a) where convert = convertVia @Text
instance (ElemBuilder m a, Convertible' Text a) => Convertible Char (BlockBuilderT m a) where convert = convertVia @String
makeLenses ''BlockBuilderT
type LineBuilder = LineBuilderT Identity
newtype LineBuilderT m a = LineBuilderT (CartTree LineBuilderT m a) deriving (Show, Functor, Traversable, Foldable, Mempty, Semigroup, P.Monoid, Concatenable)
instance ElemBuilderT LineBuilderT m a where
plainT = LineBuilderT . Plain
instance (Concatenable (m a), Monoid (m a)) => RenderT LineBuilderT m a where
renderT bb = foldl (</>) mempty $ (mconcat <$> lines) where
lines = reverse $ reverse <$> rlines
rlines = uncurry (flip (:)) $ rndr mempty mempty bb
rndr :: [[m a]] -> [m a] -> LineBuilderT m a -> ([[m a]], [m a])
rndr lines line (LineBuilderT t) = case t of
Empty -> (lines, line)
Plain a -> (lines, a:line)
Concat d l r -> case d of
Horizontal -> uncurry rndr (rndr lines line l) r
Vertical -> rndr (uncurry (flip (:)) (rndr lines line l)) mempty r
block :: (Render t a, Concatenable (t a), ElemBuilder t a, Mempty a) => t a -> t a
block t = nested t </> phantom
indented :: (ElemBuilder t a, Spacing a, Semigroup (t a)) => t a -> t a
indented t = hspacing 4 <> t
instance Convertible2 (CartTree LineBuilderT) LineBuilderT where convert2 = wrap
instance (ElemBuilder m a, IsString a) => IsString (LineBuilderT m a) where fromString = plain . fromString
instance (ElemBuilder m a, Convertible' Text a) => Convertible Text (LineBuilderT m a) where convert = plain . convert'
instance (ElemBuilder m a, Convertible' Text a) => Convertible String (LineBuilderT m a) where convert = convertVia @Text
instance (ElemBuilder m a, Convertible' Text a) => Convertible Char (LineBuilderT m a) where convert = convertVia @String
makeLenses ''LineBuilderT
type Doc a = LineBuilderT BlockBuilder (LineBlock a)
instance Measurable Text where
measure t = Bounds (convert $ Text.length t) 1
instance Stylable a => Stylable (LineBlock a)
instance (Stylable a, Functor m) => Stylable (BlockBuilderT m a)
instance (Stylable a, Functor m) => Stylable (LineBuilderT m a)
instance Measurable TermText where
measure t = Bounds (convert $ length t) 1