Wired-0.1: Layout/Internal.hs

module Layout.Internal
  ( module Layout.Floorplan
  , module Layout.Postscript
  , Layout (..)
  , LayoutT (..)
  , runLayout
  , runLayoutT
  , renderLayout
  , renderLayoutT
  , MonadLayout (..)
  , space
  , block
  , rightwards
  , leftwards
  , upwards
  , downwards
  , rightwards'
  , leftwards'
  , upwards'
  , downwards'
  , unplaced
  , stacked
  , translate
  ) where



import Control.Monad.Reader
import Control.Monad.Writer

import Data.Hardware.Internal
import Layout.Floorplan
import Layout.Postscript



newtype Layout s b a = Layout
          (ReaderT Placement (Writer [Floorplan s b]) a)
        deriving (Monad, MonadFix)

newtype LayoutT s b m a = LayoutT
          (ReaderT Placement (WriterT [Floorplan s b] m) a)
        deriving (Monad, MonadFix)



runLayout :: Layout s b a -> (a, Floorplan s b)
runLayout (Layout m) = (a, Comb Unspecified fps)
  where
    (a,fps) = runWriter $ flip runReaderT Unspecified m

runLayoutT :: Monad m => LayoutT s b m a -> m (a, Floorplan s b)
runLayoutT (LayoutT m) = do
    (a,fps) <- runWriterT $ flip runReaderT Unspecified m
    return (a, Comb Unspecified fps)

renderLayout :: String -> Layout s b a -> IO ()
renderLayout title = renderFloorplan title . snd . runLayout

renderLayoutT
    :: Monad m
    => (forall a . m a -> a)
    -> String -> LayoutT s b m a -> IO ()
renderLayoutT runner title = renderFloorplan title . snd . runner . runLayoutT



instance MonadTrans (LayoutT s b)
  where
    lift = LayoutT . lift . lift



space__ :: MonadWriter [Floorplan s b] m => Length -> Maybe s -> m ()
space__ len ms = tell [Block $ Space (Dist len) ms]

block__ :: MonadWriter [Floorplan s b] m => Width -> Height -> Name -> b -> m ()
block__ x y nm b = tell [Block $ Box (x,y) north nm b]

subLayout_
    :: (MonadReader Placement m, MonadWriter [Floorplan s b] m)
    => Placement -> m a -> m a
subLayout_ pl m = local (const pl) $ censor (\fps -> [Comb pl fps]) m

transformFloorplan_
    :: (MonadReader Placement m, MonadWriter [Floorplan s b] m)
    => (Floorplan s b -> Floorplan s b) -> m a -> m a
transformFloorplan_ trans m = do
    pl <- ask
    censor (\fps -> [trans $ Comb pl fps]) m



class Monad m => MonadLayout s b m | m -> s b
  where
    currentPlacement :: m Placement

    space_ :: Length -> Maybe s -> m ()

    block_ :: Width -> Height -> Name -> b -> m ()

    subLayout :: Placement -> m a -> m a

    transformFloorplan :: (Floorplan s b -> Floorplan s b) -> m a -> m a

instance MonadLayout s b (Layout s b)
  where
    currentPlacement = Layout ask

    space_ len ms = Layout $ space__ len ms

    block_ x y nm b = Layout $ block__ x y nm b

    subLayout pl (Layout m) = Layout $ subLayout_ pl m

    transformFloorplan trans (Layout m) = Layout $ transformFloorplan_ trans m

instance Monad m => MonadLayout s b (LayoutT s b m)
  where
    currentPlacement = LayoutT ask

    space_ len ms = LayoutT $ space__ len ms

    block_ x y nm b = LayoutT $ block__ x y nm b

    subLayout pl (LayoutT m) = LayoutT $ subLayout_ pl m

    transformFloorplan trans (LayoutT m) = LayoutT $ transformFloorplan_ trans m



space :: MonadLayout s b m => Length -> a -> m a
space len a = space_ len Nothing >> return a

block :: MonadLayout s b m => Width -> Height -> Name -> b -> a -> m a
block x y nm b a = block_ x y nm b >> return a

rightwards, leftwards, upwards, downwards :: MonadLayout s b m => m a -> m a
rightwards = subLayout (Row Rightwards BottomLeft)
leftwards  = subLayout (Row Leftwards  BottomLeft)
upwards    = subLayout (Row Upwards    BottomLeft)
downwards  = subLayout (Row Downwards  BottomLeft)

rightwards', leftwards', upwards', downwards' :: MonadLayout s b m => m a -> m a
rightwards' = subLayout (Row Rightwards TopRight)
leftwards'  = subLayout (Row Leftwards  TopRight)
upwards'    = subLayout (Row Upwards    TopRight)
downwards'  = subLayout (Row Downwards  TopRight)
  -- *** These will not be needed when elastic space has been implemented.

unplaced :: MonadLayout s b m => m a -> m a
unplaced = subLayout Unspecified

stacked :: MonadLayout s b m => m a -> m a
stacked = subLayout (Stack BottomLeft BottomLeft)

translate :: MonadLayout s bl m => Width -> Height -> m a -> m a
translate x y ma = do
    pl <- currentPlacement
    rightwards $ do
        space_ (icast x) Nothing
        upwards $ do
            space_ (icast y) Nothing
            subLayout pl ma



instance MonadLayout s b m => Transformable (m a)
  where
    flipX   = transformFloorplan flipX
    flipY   = transformFloorplan flipY
    rotate_ = transformFloorplan . rotate_