#!/usr/bin/env runhaskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# OPTIONS_GHC -Wall #-}

module Main where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.ByteString.Char8 (pack)
import qualified Data.Char as Char
import Data.List
import System.Directory
import System.Environment
import System.FilePath
import System.INotify
import System.Process

data Notify = Notify
  { notify :: IO ()
  , wait :: IO ()
  }

-- | skip channel to model concurrency semantics. this ensures that we don't
-- execute more than one command at a time.
initNotify :: IO Notify
initNotify = do
  mvar <- newMVar ()
  pure $ Notify
    (void $ tryPutMVar mvar ())
    (takeMVar mvar)

main :: IO ()
main = do
  (app, act) <- parseArgs <$> getArgs
  case act of
    Rise -> do
      inotify <- initINotify
      Notify {..} <- initNotify
      dirs <- nub . concat <$> mapM getDirs ["aero", "apex", "lore"]
      forM_ dirs $ \arg ->
        void $ addWatch inotify [Modify] (pack arg) (const notify)
      forever $ wait >> bild app >> say "waiting..."
    Make -> bild app

bild :: App -> IO ()
bild app = do
  say $ "make: " ++ name app
  apex app `catch` nop
  aero app `catch` nop
  say $ "made: " ++ name app

say :: String -> IO ()
say = putStrLn

nop :: SomeException -> IO ()
nop _ = pure ()

data Action = Make | Rise

parseArgs :: [String] -> (App, Action)
parseArgs [] = errorWithoutStackTrace "usage: chip/make [make|rise] <app>"
parseArgs (act:name:_) =
  ( App (lowercase name) (capitalize name)
  , case lowercase act of
        "rise" -> Rise
        _ -> Make
  )
parseArgs (name:_) = (App (lowercase name) (capitalize name), Make)

capitalize, lowercase :: String -> String
capitalize (α:ω) = Char.toUpper α : map Char.toLower ω
capitalize [] = []
lowercase (α:ω) = Char.toLower α : map Char.toLower ω
lowercase [] = []

data App = App
  { name :: String
  , entrypoint :: String
  }

ghcopts :: String
ghcopts = "-odir bild/ -hidir bild/ -Wall"

-- | compile with ghc.
apex :: App -> IO ()
apex App {..} = callCommand $ intercalate " "
  [ "ghc"
  , ghcopts
  , "-iapex -ilore"
  , "-main-is", entrypoint
  , "--make", "apex/" ++ entrypoint ++ ".hs"
  , "-o bild/" ++ name
  ]

-- | compile with ghcjs.
aero :: App -> IO ()
aero App {..} = callCommand $ intercalate " "
  [ "ghcjs"
  , ghcopts
  , "-iaero -ilore"
  , "-main-is", entrypoint
  , "--make", "aero/" ++ entrypoint ++ ".hs"
  , "-o bild/" ++ name
  ]

getDirs :: FilePath -> IO [FilePath]
getDirs path = do
  isDir <- doesDirectoryExist path
  if isDir
    then do
      dirs <- listDirectory path
      if null dirs
        then pure [path]
        else concat <$> do
          mapM getDirs $ (path </>) <$> dirs
    else pure [prune path]

prune :: String -> String
prune = reverse . dropWhile (/= '/') . reverse

secs :: Int -> Int
secs = (* 1000000)