{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Shoes where

import           Control.Monad.Identity
import           Control.Monad.Writer
import           Data.Text (Text)
import qualified Data.Text as T

-- | AST Type Definitions

data ShoesItem = ShoesItem
  { siItem  :: ShoesAST
  , siProps :: [Property]
  } deriving Show

newtype Action = Action { runAction :: IO () }

instance Show Action where
  show _ = "Action { ... }"

data ShoesAST
  = Button Text Action
  | Stack [ShoesItem]
  | Flow [ShoesItem]
  | Title Int Text
  | Para [Text]
  | Image Text
  | EditLine Text
  | EditBox Text
  | App ShoesAST
    deriving (Show)

data Property
  = Width ShoesUnit
  | Height ShoesUnit
  | Margin ShoesUnit
    deriving Show

-- | Number magic

instance (Num a, Num b, a ~ b) => Num ((Integer -> a) -> b) where
  fromInteger n f = f n
  (x + y) f = (x f + y f)
  (x - y) f = (x f - y f)
  (x * y) f = (x f * y f)
  abs x f = x (f . abs)
  signum x f = x (f . signum)

newtype Pixels = Pixels Int deriving (Eq, Show, Num)
newtype Percent = Percent Float deriving (Eq, Show, Num)
newtype Pt = Pt Int deriving (Eq, Show, Num)

-- data ShoesUnit
--   = Pixels Int
--   | Percent Float
--   | Pt Int
--    deriving (Eq, Show)

percent :: Integer -> Percent
percent x = Percent (fromIntegral x * 0.01)

px :: Integer -> Pixels
px = Pixels . fromIntegral

pt :: Integer -> Pt
pt = Pt . fromIntegral

data ShoesUnit
  = SUPixels Pixels
  | SUPercent Percent
  | SUPt Pt
    deriving (Eq, Show)

class ShoesNum x            where
  toShoesUnit :: x -> ShoesUnit

instance ShoesNum Pixels where
  toShoesUnit = SUPixels

instance ShoesNum Percent where
  toShoesUnit = SUPercent

instance ShoesNum Pt where
  toShoesUnit = SUPt

instance ShoesNum Integer   where
  toShoesUnit = SUPixels . Pixels . fromIntegral

-- | Property stuff

width :: ShoesNum n => n -> Property
width = Width . toShoesUnit

height :: ShoesNum n => n -> Property
height = Width . toShoesUnit

margin :: ShoesNum n => n -> Property
margin = Width . toShoesUnit

-- | Monad stuff

type ShoesM a = WriterT [ShoesItem] Identity a
type Shoes = ShoesM ()

shoesToItems :: Shoes -> [ShoesItem]
shoesToItems = snd . runIdentity . runWriterT

emit :: ShoesItem -> Shoes
emit x = tell [x]

class ShoesContainer a r | r -> a where
  mkC :: ([Property] -> Shoes -> Shoes) -> a -> r
  mkC constr = mkCW constr []

  mkCW :: ([Property] -> Shoes -> Shoes) -> [Property] -> a -> r

instance (a ~ Shoes, r ~ Shoes) => ShoesContainer [Property] (a -> r) where
  mkCW constr p p' = constr (p <> p')

instance ShoesContainer Shoes Shoes where
  mkCW constr p = constr p

--

class ShoesAction a r | r -> a where
  mkA :: ([Property] -> IO () -> Shoes) -> a -> r
  mkA c = mkAW c []
  mkAW :: ([Property] -> IO () -> Shoes) -> [Property] -> a -> r

instance ShoesAction [Property] (IO () -> Shoes) where
  mkAW c p p' = c (p <> p')

instance ShoesAction (IO ()) Shoes where
  mkAW c props = c props

--

class ShoesApp a r | r -> a where
  mkP :: ([Property] -> Shoes -> IO ()) -> a -> r
  mkP c = mkPW c []
  mkPW :: ([Property] -> Shoes -> IO ()) -> [Property] -> a -> r

instance ShoesApp [Property] (Shoes -> IO ()) where
  mkPW c p p' = c (p <> p')

instance ShoesApp Shoes (IO ()) where
  mkPW c props = c props

shoes :: ShoesApp a r => a -> r
shoes = mkP (\ _ shoes -> print $ shoesToItems shoes)

alert :: Text -> IO ()
alert _ = return ()

button :: ShoesAction a r => Text -> a -> r
button name = mkA $ \props action -> emit $ ShoesItem
  { siItem = Button name (Action action)
  , siProps = props
  }

stack :: ShoesContainer a r => a -> r
stack = mkC $ \props elem -> emit $ ShoesItem
  { siItem  = Stack (shoesToItems elem)
  , siProps = props
  }

flow :: ShoesContainer a r => a -> r
flow = mkC $ \props elem -> emit $ ShoesItem
  { siItem  = Flow (shoesToItems elem)
  , siProps = props
  }

text = undefined
image = undefined
editLine = undefined
tagline = undefined

para :: [Text] -> Shoes
para ts = emit (ShoesItem (Para ts) [])

caption = undefined
subtitle = undefined

editBox = undefined
ins = undefined
strong = undefined
em = undefined
code = undefined

banner :: Text -> Shoes
banner t = emit (ShoesItem (Title 1 t) [])

inscription = undefined
title = undefined

-- | Examples

pg20 :: IO ()
pg20 = shoes $ do
  button "Trurl?" $ do
    alert "Klapaucius!"

pg21 :: IO ()
pg21 = shoes [width (280 px), height (350 px)] $ do
  flow [width (280 px), width (10 px)] $ do
    stack [width (100 percent)] $ do
      banner "A POEM"
    stack [width (80 px)] $ do
      para [ "Goes like:" ]
    stack [width (-90 px)] $ do
      para [ "The sun.\n"
           , "a lemon.\n"
           , "the goalie.\n"
           , "a fireplace.\n\n"
           , "i want to write\n"
           , "a poem for the\n"
           , "kids who haven't\n"
           , "even heard one yet\n\n"
           , "and the goalie guards\n"
           , "the fireplace."
           ]

pg22 :: IO ()
pg22 = shoes $ do
  para [ "Testing test test. "
       , "Breadsticks. "
       , "Breadsticks. "
       , "Breadsticks. "
       , "Very good."
       ]

pg23 :: IO ()
pg23 = shoes $ do
  para [ "Testing test test. "
       , strong "Breadsticks. "
       , em "Breadsticks. "
       , code "Breadsticks. "
       , strong (ins "Very good.")
       ]

pg23' :: IO ()
pg23' = shoes $ do
  title "Title"
  subtitle "Subtitle"
  tagline "Tagline"
  caption "Caption"
  para ["Para"]
  inscription "Inscription"

{-
pg29 = shoes $ do
  o <- oval [top 0, left 0, radius 40]
  stack [margin 40] $ do
    title "Dancing With a Circle"
    subtitle "How graceful and round."
  motion $ \ x y -> do
    move x (width - x) (height - y)
-}

pg32 :: IO ()
pg32 = shoes $ do
  image "j.jpg"

pg35 :: IO ()
pg35 = shoes $ do
  editLine [width (400 px)]

pg35' :: IO ()
pg35' = shoes $ do
  e <- editLine [width (400 px)]
  button "O.K." $ do
    txt <- text e
    alert txt

pg36 :: IO ()
pg36 = shoes $ do
  editBox [width (400 px), height (240 px)] "Would that I..."

pg36' :: IO ()
pg36' = shoes $ do
  stack $ do
    editLine "Sample sample."
    button "Breadsticks." (return ())