explorer: better blocs layout

explorer/src/Button.elm

@@ -18,16 +18,23 @@ import Widget.Material.Typography as Typography
 page =
     Tooling.firstBloc (intro |> Tooling.withBlocTitle "Button")
         |> Tooling.nextBlocList book
+        |> Tooling.nextBloc demo
         |> Tooling.page
 
 
 intro =
-    Tooling.markdown
+    Tooling.markdown []
         """ A simple button """
 
 
 book =
-    Story.book (Just "States") buttonBlocs
+    Story.book (Just "States")
+        (Story.initStaticBlocs
+            |> Story.addBloc Tooling.LeftColumnBloc
+                [ Background.color <| MaterialColor.fromColor MaterialColor.gray ]
+                Nothing
+                viewButton
+        )
         |> Story.addStory
             (Story.optionListStory "Palette"
                 defaultPalette
@@ -52,7 +59,7 @@ book =
             )
         |> Story.addStory
             (Story.boolStory "with event handler"
-                ( Just Noop, Nothing )
+                ( Just (), Nothing )
                 True
             )
         |> Story.addStory
@@ -66,6 +73,21 @@ book =
         |> Story.build
 
 
+viewButton palette text icon onPress size _ _ =
+    Widget.button
+        (containedButton palette
+            |> Customize.elementButton
+                [ Element.height <| Element.px size
+                , Element.centerX
+                , Element.centerY
+                ]
+        )
+        { text = text
+        , icon = icon
+        , onPress = onPress
+        }
+
+
 type alias Model =
     Int
 
@@ -77,20 +99,19 @@ type Msg
     | Noop
 
 
-buttonBlocs =
-    Story.initBlocs
-        { init = always init
-        , update = update
-        , subscriptions = subscriptions
-        }
-        |> Story.addBloc Nothing viewButton
-        |> Story.addBloc (Just "Interactive example") view
-
-
 
 --|> Story.addBloc (Just "Interactive example") view
 
 
+demo =
+    { init = always init
+    , update = update
+    , title = Just "Interactive Demo"
+    , view = view
+    , subscriptions = subscriptions
+    }
+
+
 init : ( Model, Cmd Msg )
 init =
     ( 0, Cmd.none )
@@ -127,20 +148,11 @@ subscriptions _ =
     Sub.none
 
 
-viewButton palette text icon onPress size _ _ =
+view _ model =
-    Tooling.canvas <|
-        Widget.button
-            (containedButton palette
-                |> Customize.elementButton [ Element.height <| Element.px size ]
-            )
-            { text = text
-            , icon = icon
-            , onPress = onPress
-            }
-
-
-view palette _ _ _ _ _ model =
     let
+        palette =
+            Material.defaultPalette
+
         style =
             { containedButton = Material.containedButton palette
             , outlinedButton = Material.outlinedButton palette
@@ -151,6 +163,9 @@ view palette _ _ _ _ _ model =
             , cardColumn = Material.cardColumn palette
             }
     in
+    { position = Tooling.FullWidthBloc
+    , attributes = []
+    , body =
         [ model
             |> String.fromInt
             |> Element.text
@@ -231,3 +246,4 @@ view palette _ _ _ _ _ model =
                     |> Customize.elementColumn [ Element.width <| Element.fill ]
                     |> Customize.mapContent (Customize.element [ Element.width <| Element.fill ])
                 )
+    }

explorer/src/Story.elm

@@ -1,7 +1,7 @@
 module Story exposing (..)
 
 import Dict exposing (Dict)
-import Element exposing (Element)
+import Element exposing (Attribute, Element)
 import Element.Input as Input exposing (Label, Option, labelAbove, option, radio)
 import SelectList exposing (SelectList)
 import Tooling
@@ -78,7 +78,7 @@ type alias BlocList view model msg flags =
     { init : flags -> ( model, Cmd msg )
     , update : msg -> model -> ( model, Cmd msg )
     , titles : List (Maybe String)
-    , views : List view
+    , views : List ( Tooling.BlocPosition, List (Attribute msg), view )
     , subscriptions : model -> Sub msg
     }
 
@@ -87,7 +87,7 @@ type alias BlocListBuilder view model msg flags a =
     { init : flags -> ( model, Cmd msg )
     , update : msg -> model -> ( model, Cmd msg )
     , titles : List (Maybe String)
-    , views : a -> List view
+    , views : a -> List ( Tooling.BlocPosition, List (Attribute msg), view )
     , subscriptions : model -> Sub msg
     }
 
@@ -146,17 +146,7 @@ addStoryToBlocList builder =
     , views =
         \( a, previous ) ->
             builder.views previous
-                |> List.map (\view -> view a)
+                |> List.map (\( position, attrs, view ) -> ( position, attrs, view a ))
-    }
-
-
-static : view -> BlocList view flags msg flags
-static blocView =
-    { init = \flags -> ( flags, Cmd.none )
-    , titles = [ Nothing ]
-    , update = \_ m -> ( m, Cmd.none )
-    , views = [ blocView ]
-    , subscriptions = \_ -> Sub.none
     }
 
 
@@ -175,11 +165,27 @@ initBlocs { init, update, subscriptions } =
     }
 
 
-addBloc : Maybe String -> view -> BlocList view model msg flags -> BlocList view model msg flags
+addBloc :
-addBloc title view bloclist =
+    Tooling.BlocPosition
+    -> List (Attribute msg)
+    -> Maybe String
+    -> view
+    -> BlocList view model msg flags
+    -> BlocList view model msg flags
+addBloc position attributes title view bloclist =
     { bloclist
         | titles = List.append bloclist.titles [ title ]
-        , views = List.append bloclist.views [ view ]
+        , views = List.append bloclist.views [ ( position, attributes, view ) ]
+    }
+
+
+initStaticBlocs : BlocList view () () ()
+initStaticBlocs =
+    { init = always ( (), Cmd.none )
+    , titles = []
+    , update = \_ _ -> ( (), Cmd.none )
+    , views = []
+    , subscriptions = always Sub.none
     }
 
 
@@ -384,7 +390,8 @@ storyBloc title stories storiesToValue =
     , subscriptions = always Sub.none
     , views =
         \_ model ->
-            [ { sidebloc = True
+            [ { position = Tooling.NewRightColumnBloc
+              , attributes = []
               , body =
                     model
                         |> List.map storyView
@@ -409,8 +416,9 @@ build builder =
             , views =
                 \pagesize ( selectorModel, model ) ->
                     List.map
-                        (\view ->
+                        (\( position, attrs, view ) ->
-                            { sidebloc = False
+                            { position = position
+                            , attributes = attrs
                             , body = view pagesize model
                             }
                         )

explorer/src/Tooling.elm

@@ -1,25 +1,38 @@
 module Tooling exposing (..)
 
 import Dict exposing (Dict)
-import Element exposing (Element)
+import Element exposing (Attribute, Element)
+import Element.Background as Background
 import Markdown
 import SelectList exposing (SelectList)
 import UiExplorer exposing (Page, PageSize)
 import Widget
+import Widget.Customize as Customize
 import Widget.Material as Material
+import Widget.Material.Color as MaterialColor
 import Widget.Material.Typography as Typography
 
 
+type BlocPosition
+    = FullWidthBloc
+    | RightColumnBloc
+    | NewRightColumnBloc
+    | LeftColumnBloc
+    | NewLeftColumnBloc
+
+
 type alias BlocView msg =
     { body : Element msg
-    , sidebloc : Bool
+    , position : BlocPosition
+    , attributes : List (Attribute msg)
     }
 
 
 mapBlocView : (a -> b) -> BlocView a -> BlocView b
 mapBlocView map view =
     { body = Element.map map view.body
-    , sidebloc = view.sidebloc
+    , position = view.position
+    , attributes = List.map (Element.mapAttribute map) view.attributes
     }
 
 
@@ -129,6 +142,10 @@ blocListSingleton bloc =
     }
 
 
+type alias BlocMeta =
+    { title : Maybe String }
+
+
 {-| -}
 type BlocBuilder model msg flags
     = BlocBuilder
@@ -136,7 +153,7 @@ type BlocBuilder model msg flags
         , update : msg -> model -> ( model, Cmd msg )
         , views : PageSize -> model -> List (BlocView msg)
         , subscriptions : model -> Sub msg
-        , meta : List { title : Maybe String }
+        , meta : List BlocMeta
         }
 
 
@@ -228,48 +245,120 @@ nextBlocList config (BlocBuilder previous) =
         }
 
 
-page : BlocBuilder model msg flags -> Page model msg flags
+type LayoutRow msg
-page (BlocBuilder config) =
+    = OneColumn (List ( BlocMeta, BlocView msg ))
-    { init = config.init
+    | TwoColumn (List ( BlocMeta, BlocView msg )) (List ( BlocMeta, BlocView msg ))
-    , update = config.update
+
-    , view =
+
-        \pagesize model ->
+type alias Layout msg =
-            let
+    List (LayoutRow msg)
-                ( sideblocs, blocs ) =
+
-                    config.views pagesize model
+
-                        |> List.map2
+layoutAddBloc : ( BlocMeta, BlocView msg ) -> Layout msg -> Layout msg
-                            (\meta view ->
+layoutAddBloc ( meta, view ) layout =
-                                ( view.sidebloc
+    case view.position of
-                                , Widget.column (Material.cardColumn Material.defaultPalette) <|
+        FullWidthBloc ->
+            case layout of
+                (OneColumn items) :: tail ->
+                    OneColumn (( meta, view ) :: items) :: tail
+
+                _ ->
+                    OneColumn [ ( meta, view ) ] :: layout
+
+        LeftColumnBloc ->
+            case layout of
+                (TwoColumn left right) :: tail ->
+                    TwoColumn (( meta, view ) :: left) right :: tail
+
+                _ ->
+                    TwoColumn [ ( meta, view ) ] [] :: layout
+
+        NewLeftColumnBloc ->
+            TwoColumn [ ( meta, view ) ] [] :: layout
+
+        RightColumnBloc ->
+            case layout of
+                (TwoColumn left right) :: tail ->
+                    TwoColumn left (( meta, view ) :: right) :: tail
+
+                _ ->
+                    TwoColumn [] [ ( meta, view ) ] :: layout
+
+        NewRightColumnBloc ->
+            TwoColumn [] [ ( meta, view ) ] :: layout
+
+
+layoutBlocView : List (Attribute msg) -> ( BlocMeta, BlocView msg ) -> Element msg
+layoutBlocView attributes ( meta, view ) =
+    Widget.column
+        (Material.cardColumn Material.defaultPalette
+            |> Customize.elementColumn attributes
+            |> Customize.mapContent (Customize.element <| Element.height Element.fill :: view.attributes)
+        )
+    <|
         List.filterMap identity
             [ meta.title
                 |> Maybe.map Element.text
                 |> Maybe.map (Element.el Typography.h3)
             , Just view.body
             ]
-                                )
+
-                            )
+
-                            config.meta
+layoutRowView : LayoutRow msg -> List (Element msg)
-                        |> List.partition Tuple.first
+layoutRowView row =
-                        |> Tuple.mapBoth (List.map Tuple.second) (List.map Tuple.second)
+    case row of
-            in
+        OneColumn items ->
+            items
+                |> List.reverse
+                |> List.map (layoutBlocView [])
+
+        TwoColumn left right ->
             Element.row
-                [ Element.width Element.shrink
+                [ Element.width Element.fill
-                , Element.centerX
                 , Element.spacing 10
                 ]
                 [ Element.column
+                    [ Element.width <| Element.fillPortion 2
+                    , Element.height Element.fill
+                    ]
+                  <|
+                    List.map
+                        (layoutBlocView
+                            [ Element.height Element.fill ]
+                        )
+                    <|
+                        List.reverse left
+                , Element.column
+                    [ Element.width <| Element.fillPortion 1
+                    , Element.height Element.fill
+                    ]
+                  <|
+                    List.map
+                        (layoutBlocView
+                            [ Element.height Element.fill ]
+                        )
+                    <|
+                        List.reverse right
+                ]
+                |> List.singleton
+
+
+page : BlocBuilder model msg flags -> Page model msg flags
+page (BlocBuilder config) =
+    { init = config.init
+    , update = config.update
+    , view =
+        \pagesize model ->
+            config.views pagesize model
+                |> List.map2 Tuple.pair config.meta
+                |> List.foldl layoutAddBloc []
+                |> List.reverse
+                |> List.concatMap layoutRowView
+                |> Element.column
                     [ Element.padding 10
                     , Element.spacing 10
                     , Element.px 800 |> Element.width
-                    ]
+                    , Element.centerX
-                    blocs
-                , Element.column
-                    [ Element.padding 10
-                    , Element.spacing 10
-                    , Element.px 400 |> Element.width
-                    ]
-                    sideblocs
                     ]
     , subscriptions = config.subscriptions
     }
@@ -277,21 +366,26 @@ page (BlocBuilder config) =
 
 {-| render a markdown text into a simple panel
 -}
-markdown : String -> Bloc () () ()
+markdown : List (Attribute ()) -> String -> Bloc () () ()
-markdown text =
+markdown attributes text =
-    static
+    static attributes
         (\_ _ ->
             Markdown.toHtml [] text
                 |> Element.html
         )
 
 
-static : (PageSize -> flags -> Element msg) -> Bloc flags msg flags
+static : List (Attribute msg) -> (PageSize -> flags -> Element msg) -> Bloc flags msg flags
-static blocView =
+static attributes blocView =
     { init = \flags -> ( flags, Cmd.none )
     , title = Nothing
     , update = \_ m -> ( m, Cmd.none )
-    , view = \pagesize flags -> { body = blocView pagesize flags, sidebloc = False }
+    , view =
+        \pagesize flags ->
+            { body = blocView pagesize flags
+            , position = FullWidthBloc
+            , attributes = attributes
+            }
     , subscriptions = \_ -> Sub.none
     }
 
@@ -306,23 +400,11 @@ canvas view =
     Element.el
         [ Element.padding 30
         , Element.width Element.fill
+        , Background.color <| MaterialColor.fromColor <| MaterialColor.gray
         ]
     <|
         Element.el
             [ Element.centerX
-            , Element.width Element.shrink
+            , Element.centerY
             ]
             view
-
-
-assidebloc : Bloc model msg flags -> Bloc model msg flags
-assidebloc bloc =
-    { bloc
-        | view =
-            \pagesize model ->
-                let
-                    sidebloc =
-                        bloc.view pagesize model
-                in
-                { sidebloc | sidebloc = True }
-    }