Care for some tabs?

tabs.elm

import Html exposing (Html)
import Html.Attributes
import Html.Events
import Signal exposing (Address)
import Window
import Color exposing (Color)
------------

type alias Vector = 
  { x : Float , y : Float }
  
infixl 2 =>  
(=>) = (,)

toRgbaString : Color -> String
toRgbaString color = 
  let {red, green, blue, alpha} = Color.toRgb color 
  in 
      "rgba(" ++ toString red ++ ", " ++ toString green ++ ", " ++ toString blue ++ ", " ++ toString alpha ++ ")"
 
------------

type alias SelectionList a = 
  { previous : List a
  , current  : a
  , next     : List a
  }
  
toList : SelectionList a -> List a
toList list = 
  List.reverse list.previous ++ [ list.current ] ++ list.next 
  
  
fromList : a -> List a -> SelectionList a 
fromList current next = 
  SelectionList [] current next
  
length : SelectionList a -> Int
length list = 
  List.length list.previous + 1 + List.length list.next
  
map : (a -> b) -> SelectionList a -> SelectionList b 
map f list = 
  { list | previous <- List.map f list.previous
         , current  <- f list.current 
         , next     <- List.map f list.next 
  }
  
  
indexedMap : (Int -> a -> b) -> SelectionList a -> SelectionList b 
indexedMap f list = 
  let 
      previousLength = List.length list.previous
      nextLength = List.length list.next 
  in 
      { list | previous <- List.reverse (List.indexedMap f (List.reverse list.previous))
             , current  <- f previousLength list.current 
             , next     <- List.indexedMap (\index -> f (index + previousLength + 1)) list.next
      }
  

forward : SelectionList a -> SelectionList a
forward list = 
  case list.next of 
    [] -> 
      list 
      
    x :: xs ->
      { list | current  <- x 
             , previous <- list.current :: list.previous 
             , next     <- xs
      }
      
  
back : SelectionList a -> SelectionList a
back list = 
  case list.previous of 
    [] -> 
      list 
      
    x :: xs ->
      { list | current  <- x 
             , previous <- xs 
             , next     <- list.current :: list.next
      }
   
currentIndex : SelectionList a -> Int 
currentIndex list = 
  List.length list.previous
  
goto : Int -> SelectionList a -> SelectionList a 
goto n list = 
  let 
      curIndex = currentIndex list 
  in 
      if | curIndex == n -> 
             list
              
         | curIndex < n && List.length list.next > 0 -> 
             goto n (forward list)
             
         | curIndex > (max 0 n) ->
             goto n (back list)
             
         | otherwise -> 
             list   
   
   
------------

type alias State =
  { tabs : SelectionList String 
  
  }
  
initial : State 
initial = 
  { tabs = fromList "Menu" [ "About", "Blog", "Contact" ] }  
    
type alias Context = 
  { size : Vector
  , ink  : Color 
  }
  
context = 
  { size = { x = 400, y = 44 }
  , ink  = Color.yellow 
  }

type Action 
  = Select Int
  | Next
  | Previous
  
  
  
update : Action -> State -> State 
update action state = 
  case action of 
    Select index -> 
      { state | tabs <- goto index state.tabs }
    
    Next -> 
      { state | tabs <- forward state.tabs }
    
    Previous ->
      { state | tabs <- back state.tabs }

  
 
view : Context -> Address Action -> State -> Html 
view context address state = 
  let 
      containerStyle = 
          [ "position" => "absolute"
          , "left" => "0px"
          , "top" => "0px"
          , "width" => toString context.size.x ++ "px"
          , "height" => toString context.size.y ++ "px"
          ]
      
      tabLength = 
          length state.tabs
        
        
      curIndex = 
          currentIndex state.tabs
        
      tabSize = 
          { x = if tabLength == 0 then 0 else context.size.x / toFloat tabLength
          , y = context.size.y
          }
        
      left = 
        toFloat curIndex * tabSize.x
        
      fontSize = 
        context.size.y / 2
        
      inkStyle = 
           [ "position" => "absolute"
           , "left" => toString left ++ "px"
           , "top" => toString tabSize.y ++ "px"
           , "width" => toString tabSize.x ++ "px"
           , "height" => "2px"
           , "background-color" => toRgbaString context.ink 
           , "transition" => "left 0.2s ease-out"
           ]
           
      ink = 
        Html.div
            [ Html.Attributes.style inkStyle ]
            []
      
      viewN index tab = 
          let 
              left = 
                tabSize.x * toFloat index
          
              tabContainerStyle = 
                  [ "position" => "absolute"
                  , "left"     => toString left ++ "px"
                  , "top"      => "0px"
                  , "width"    => toString tabSize.x ++ "px"
                  , "height"   => toString tabSize.y ++ "px"
                  , "cursor"   => "pointer"
                  , "display"  => "flex"
                  , "align-items"     => "center"
                  , "justify-content" => "center"
                  , "text-align" => "center"
                  ]
                  
              textStyle = 
                  [ "text-transform" => "uppercase"
                  , "font-size" => toString fontSize ++ "px" 
                  ]
                  
              
                  
          in
              Html.div 
                  [ Html.Attributes.style tabContainerStyle 
                  , Html.Events.onClick address (Select index)
                  ]
                  [ Html.span 
                        [ Html.Attributes.style textStyle ] 
                        [ Html.text tab ] 
                  ]
   in 
       Html.div 
           [ Html.Attributes.style containerStyle ]
           ( ink :: toList ( indexedMap viewN state.tabs ))

-------------


  
  
type alias ApplicationState = 
  { state   : State 
  , context : Context 
  }
  
initialApp : ApplicationState 
initialApp = 
  { state = initial
  , context = context
  }
  
type ApplicationAction  
  = Resize Int 
  | ApplicationAction Action 
  | NoOp
  
  
updateApp : ApplicationAction -> ApplicationState -> ApplicationState 
updateApp action state = 
  case action of 
    Resize width -> 
       let 
           context = state.context
           
           size = context.size 
           
           size' = 
             { size | x <- toFloat width }
             
           context' = 
             { context | size <- size' }
       in 
           { state | context <- context' }
           
           
    ApplicationAction action -> 
        { state | state <- update action state.state }
        
    NoOp -> 
        state
  
  
  
viewApp : Address ApplicationAction -> ApplicationState -> Html 
viewApp address state = 
  view state.context (Signal.forwardTo address ApplicationAction) state.state
  
  
mainMailbox = 
  Signal.mailbox NoOp

address = 
  mainMailbox.address

signal = 
  Signal.merge 
    (mainMailbox.signal)
    (Signal.map Resize Window.width)
  
 
main = 
  Signal.map (viewApp address)
    (Signal.foldp updateApp initialApp signal)