take away io and put aff back in

take away io and put aff back in

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(Left, Right))
import Data.Foreign (Foreign)
import Data.Function.Uncurried (Fn3)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.Express.App (App, AppM, listenHttp, use, useExternal)
import Node.Express.App as E
import Node.Express.Handler (HandlerM(HandlerM))
import Node.Express.Middleware.Static (static)
import Node.Express.Response (sendJson, setStatus)
import Node.Express.Types (ExpressM, Request, Response)
import Node.FS (FS)
import Node.FS.Aff (mkdir, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, lookupEnv, platform)
import Routes (GetRoute, PostRoute, files, getIcons, open, remove, update, watched)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Simple.JSON (class ReadForeign, class WriteForeign, read, write)
import Types (FileData(FileData), GetIconsRequest, OpenRequest(OpenRequest), Path(Path), RemoveRequest(RemoveRequest), Success(Success), WatchedData)
import Unsafe.Coerce (unsafeCoerce)

readdir' :: forall eff.
  String
  -> Aff
       ( fs :: FS
       | eff
       )
       (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: forall e.
  Int
  -> String
  -> Eff
    ( buffer :: BUFFER
    | e
    )
    Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff
  )

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => GetFiles (Aff e) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => GetWatched (Aff e) where
  getWatchedData {db} = do
    watchedData :: Array WatchedData <- liftAff $ unsafeCoerce <$>
      queryDB db "SELECT path, created FROM watched;" []
    pure $ watchedData

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Success

instance giA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => GetIcons (Aff e) where
  getIconsData {db} _ = do
    _ <- liftAff <<< liftEff $ spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ Success {status: "ok"}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => UpdateWatched (Aff e) where
  updateWatched config@{db} (FileData ur) = do
    _ <- liftAff $ if ur.watched
      then queryDB db "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
      else queryDB db "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Success)

instance ofA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => OpenFile (Aff e) where
  openFile {dir} (OpenRequest or) = do
    _ <- liftAff $ case platform of
          Just Darwin -> liftEff $ void $ spawn "open" (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEff $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ Success {status: "ok"}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Success)

instance rfA ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => RemoveFile (Aff e) where
  removeFile {dir} (RemoveRequest rr) = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ Success {status: "ok"}

ensureDB :: forall eff. FilePath -> Aff (db :: DBEffects | eff) DBConnection
ensureDB path = do
  db <- newDB path
  _ <- queryDB db "CREATE TABLE IF NOT EXISTS watched (path varchar(20) primary key unique, created datetime);" []
  pure db

foreign import jsonBodyParser :: forall e. Fn3 Request Response (ExpressM e Unit) (ExpressM e Unit)

foreign import _getBody :: Request -> Foreign

getBody :: forall e. HandlerM e Foreign
getBody = HandlerM \req _ _ -> pure $ _getBody req

handleGet :: forall res url
    . IsSymbol url
  => WriteForeign res
  => Config
  -> GetRoute res url
  -> (Config -> Aff _ res)
  -> AppM _ Unit
handleGet config route action =
  E.get route handler'
  where
    route = reflectSymbol (SProxy :: SProxy url)
    handler' = do
      response <- liftAff $ action config
      sendJson $ write response

handlePost :: forall req res url
    . IsSymbol url
  => WriteForeign res
  => ReadForeign req
  => Config
  -> PostRoute req res url
  -> (Config -> req -> Aff _ res)
  -> AppM _ Unit
handlePost config route action =
  E.post route handler'
  where
    route = reflectSymbol (SProxy :: SProxy url)
    handler' = do
      body <- getBody
      case runExcept (read body) of
        Right (r :: req) -> do
          response <- liftAff $ action config r
          sendJson $ write response
        Left e -> do
          setStatus 400
          sendJson $ write {error: show e}

routes :: Config -> App _
routes config = do
  useExternal jsonBodyParser
  get files getFiles
  get watched getWatchedData
  post getIcons getIconsData
  post update updateWatched
  post open openFile
  post remove removeFile
  use $ static "dist"
  where
    get :: forall res url
       . IsSymbol url
      => WriteForeign res
      => GetRoute res url
      -> (Config -> Aff _ res)
      -> AppM _ Unit
    get = handleGet config

    post :: forall req res url
       . IsSymbol url
      => WriteForeign res
      => ReadForeign req
      => PostRoute req res url
      -> (Config -> req -> Aff _ res)
      -> AppM _ Unit
    post = handlePost config

main :: Eff _ Unit
main = void $ launchAff do
  dir' <- liftEff $ lookupEnv "FILETRACKER_DIR"
  case dir' of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      void $ liftEff $ listenHttp (routes {db, dir}) 3000 \_ ->
        log "Started server"

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Control.Monad.IO (IO, runIO')
import Data.Array (filter, sortBy)
import Data.Either (Either(Left, Right))
import Data.Foreign (Foreign)
import Data.Function.Uncurried (Fn3)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.Express.App (App, AppM, listenHttp, use, useExternal)
import Node.Express.App as E
import Node.Express.Handler (HandlerM(HandlerM))
import Node.Express.Middleware.Static (static)
import Node.Express.Response (sendJson, setStatus)
import Node.Express.Types (ExpressM, Request, Response)
import Node.FS (FS)
import Node.FS.Aff (mkdir, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, lookupEnv, platform)
import Routes (GetRoute, PostRoute, files, getIcons, open, remove, update, watched)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Simple.JSON (class ReadForeign, class WriteForeign, read, write)
import Types (FileData(FileData), GetIconsRequest, OpenRequest(OpenRequest), Path(Path), RemoveRequest(RemoveRequest), Success(Success), WatchedData)
import Unsafe.Coerce (unsafeCoerce)

readdir' :: forall eff.
  String
  -> Aff
       ( fs :: FS
       | eff
       )
       (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: forall e.
  Int
  -> String
  -> Eff
    ( buffer :: BUFFER
    | e
    )
    Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff
  )

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfA :: GetFiles IO where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA :: GetWatched IO where
  getWatchedData {db} = do
    watchedData :: Array WatchedData <- liftAff $ unsafeCoerce <$>
      queryDB db "SELECT path, created FROM watched;" []
    pure $ watchedData

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Success

instance giA :: GetIcons IO where
  getIconsData {db} _ = do
    _ <- liftEff $ void $ spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ Success {status: "ok"}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA :: UpdateWatched IO where
  updateWatched config@{db} (FileData ur) = do
    _ <- liftAff $ if ur.watched
      then queryDB db "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
      else queryDB db "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Success)

instance ofA :: OpenFile IO where
  openFile {dir} (OpenRequest or) = do
    _ <- liftAff $ case platform of
          Just Darwin -> liftEff $ void $ spawn "open" (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEff $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ Success {status: "ok"}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Success)

instance rfA :: RemoveFile IO where
  removeFile {dir} (RemoveRequest rr) = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ Success {status: "ok"}

ensureDB :: forall eff. FilePath -> Aff (db :: DBEffects | eff) DBConnection
ensureDB path = do
  db <- newDB path
  _ <- queryDB db "CREATE TABLE IF NOT EXISTS watched (path varchar(20) primary key unique, created datetime);" []
  pure db

foreign import jsonBodyParser :: forall e. Fn3 Request Response (ExpressM e Unit) (ExpressM e Unit)

foreign import _getBody :: Request -> Foreign

getBody :: forall e. HandlerM e Foreign
getBody = HandlerM \req _ _ -> pure $ _getBody req

handleGet :: forall res url
    . IsSymbol url
  => WriteForeign res
  => Config
  -> GetRoute res url
  -> (Config -> IO res)
  -> AppM _ Unit
handleGet config route action =
  E.get route handler'
  where
    route = reflectSymbol (SProxy :: SProxy url)
    handler' = do
      response <- liftAff <<< runIO' $ action config
      sendJson $ write response

handlePost :: forall req res url
    . IsSymbol url
  => WriteForeign res
  => ReadForeign req
  => Config
  -> PostRoute req res url
  -> (Config -> req -> IO res)
  -> AppM _ Unit
handlePost config route action =
  E.post route handler'
  where
    route = reflectSymbol (SProxy :: SProxy url)
    handler' = do
      body <- getBody
      case runExcept (read body) of
        Right (r :: req) -> do
          response <- liftAff <<< runIO' $ action config r
          sendJson $ write response
        Left e -> do
          setStatus 400
          sendJson $ write {error: show e}

routes :: Config -> App _
routes config = do
  useExternal jsonBodyParser
  get files getFiles
  get watched getWatchedData
  post getIcons getIconsData
  post update updateWatched
  post open openFile
  post remove removeFile
  use $ static "dist"
  where
    get :: forall res url
       . IsSymbol url
      => WriteForeign res
      => GetRoute res url
      -> (Config -> IO res)
      -> AppM _ Unit
    get = handleGet config

    post :: forall req res url
       . IsSymbol url
      => WriteForeign res
      => ReadForeign req
      => PostRoute req res url
      -> (Config -> req -> IO res)
      -> AppM _ Unit
    post = handlePost config

main :: Eff _ Unit
main = void $ launchAff do
  dir' <- liftEff $ lookupEnv "FILETRACKER_DIR"
  case dir' of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      void $ liftEff $ listenHttp (routes {db, dir}) 3000 \_ ->
        log "Started server"


newtype is suitable here

newtype is suitable here

-- / What is in the hand during a round
module App.Hand where

import Data.Maybe
import App.Board as Board
import App.Board (class HasBoard)
import Data.Function (apply)
import Data.List (List(..), (:), concat, foldr)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)
import Prelude ((>>>), (<<<), ($), map)

newtype State = State
  { player :: Board.Player
  , seeds :: Board.Cell
  , pitRef :: Board.PitRef
  , board :: Board.State
  }

instance hasBoardHand :: HasBoard State where
  getBoard (State h) = h.board

init :: Board.Player -> Board.PitRef -> Board.State -> State
init player pitRef board = State
  { player: player
  , seeds: 0
  , pitRef: pitRef
  , board: board
  }

opponent :: State -> Board.Player
opponent (State { player }) = Board.opponentOf player

unfoldTurns :: State -> List (State -> State)
unfoldTurns = concat <<< unfoldr' nextTurns

nextTurns :: State -> Tuple (List (State -> State)) (Maybe State)
nextTurns (State state@{ player, seeds, pitRef, board }) =
  go seeds
     (Board.lookup pitRef board)
     (Board.lookup (Board.nextRef pitRef) board)
     (Board.lookup ((Board.nextRef <<< Board.nextRef) pitRef) board)
     state
    where continue xs = Tuple xs (Just $ applyTurns xs $ State state)
          end xs = Tuple xs Nothing
          go 0 0 0 _ state' =
            end $ Nil
          go 0 0 s _ state' =
            end $ advance : capture : Nil
          go _ _ _ _ state' =
            end $ Nil -- TODO: signal not reachable state

applyTurns :: List (State -> State) -> State -> State
applyTurns turns s = foldr apply s turns

advance :: State -> State
advance state =
  state -- TODO

capture :: State -> State
capture (State state@{ player, seeds, pitRef, board }) =
  State $ state { board = board' }
  where board' = ( Board.clear pitRef >>> Board.store player seeds' ) board
        seeds'  = Board.lookup pitRef board
-- | A version of unfoldr that allows a elements in end cause.
unfoldr' :: forall a b t. Unfoldable t
        => (b -> Tuple a (Maybe b)) -> b -> t a
unfoldr' f = unfoldr (map f) <<< Just

-- / What is in the hand during a round
module App.Hand where

import Data.Maybe
import App.Board as Board
import App.Board (class HasBoard)
import Data.Function (apply)
import Data.List (List(..), (:), concat, foldr)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)
import Prelude ((>>>), (<<<), ($), map)

data State = Hand
  { player :: Board.Player
  , seeds :: Board.Cell
  , pitRef :: Board.PitRef
  , board :: Board.State
  }

instance hasBoardHand :: HasBoard State where
  getBoard (Hand h) = h.board

init :: Board.Player -> Board.PitRef -> Board.State -> State
init player pitRef board = Hand
  { player: player
  , seeds: 0
  , pitRef: pitRef
  , board: board
  }

opponent :: State -> Board.Player
opponent (Hand { player }) = Board.opponentOf player

unfoldTurns :: State -> List (State -> State)
unfoldTurns = concat <<< unfoldr' nextTurns

nextTurns :: State -> Tuple (List (State -> State)) (Maybe State)
nextTurns (Hand state@{ player, seeds, pitRef, board }) =
  go seeds
     (Board.lookup pitRef board)
     (Board.lookup (Board.nextRef pitRef) board)
     (Board.lookup ((Board.nextRef <<< Board.nextRef) pitRef) board)
     state
    where continue xs = Tuple xs (Just $ applyTurns xs $ Hand state)
          end xs = Tuple xs Nothing
          go 0 0 0 _ state' =
            end $ Nil
          go 0 0 s _ state' =
            end $ advance : capture : Nil
          go _ _ _ _ state' =
            end $ Nil -- TODO: signal not reachable state

applyTurns :: List (State -> State) -> State -> State
applyTurns turns s = foldr apply s turns

advance :: State -> State
advance state =
  state -- TODO

capture :: State -> State
capture (Hand state@{ player, seeds, pitRef, board }) =
  Hand $ state { board = board' }
  where board' = ( Board.clear pitRef >>> Board.store player seeds' ) board
        seeds'  = Board.lookup pitRef board
-- | A version of unfoldr that allows a elements in end cause.
unfoldr' :: forall a b t. Unfoldable t
        => (b -> Tuple a (Maybe b)) -> b -> t a
unfoldr' f = unfoldr (map f) <<< Just


order results from watched

order results from watched

module Main where

import Prelude

import Config as C
import Control.Monad.Except (ExceptT, except, runExceptT, throwError)
import Data.Array (filter, sortBy)
import Data.Bifunctor (lmap)
import Data.Either (Either(Left, Right))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse, traverse_)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Effect (Effect)
import Effect.Aff (Aff, attempt, launchAff_)
import Effect.Aff.Class (liftAff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Jajanmen as J
import Makkori as M
import Node.Buffer (Buffer, create, writeString)
import Node.ChildProcess (Exit(..), defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.FS.Aff (mkdir, readTextFile, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (platform)
import Prim.Row as Row
import Record as Record
import Routes (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, FilePath, newDB)
import SQLite3 as SQL
import Shoronpo (formatSymbol, intercalateRecordLabels, intercalateRowLabels, intercalateRowValues)
import Simple.JSON (class ReadForeign, class WriteForeign, read, writeJSON)
import Sunde as Sunde
import Tortellini (parsellIni)
import Type.Prelude (class RowToList, Proxy(..), RLProxy(RLProxy))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData, GetIconsRequest, OpenRequest, Operation, Path(Path), RemoveRequest, WatchedData)

data Error
  = ServerError String
  | UserError String

prepareResult :: forall a. WriteForeign a => Either Error a -> {status :: Int, response :: String}
prepareResult (Left (UserError error)) = {status: 400, response: writeJSON {error}}
prepareResult (Left (ServerError error)) = {status: 500, response: writeJSON {error}}
prepareResult (Right result) = {status: 200, response: writeJSON result}

readdir' :: String -> Aff (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: Int -> String -> Effect Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  , exe :: String
  }

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF :: GetFiles (ExceptT Error Aff) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA :: GetWatched (ExceptT Error Aff) where
  getWatchedData {db} = do
    let
      template = SProxy :: SProxy "select {columns} from watched order by created desc"
      query = formatSymbol template
        { columns: intercalateRecordLabels (Proxy :: Proxy WatchedData) (SProxy :: SProxy ", ") }
    results <- liftAff $ J.queryDB db query {}
    case read results of
      Right xs -> do
        pure xs
      Left e -> do
        throwError <<< ServerError $ "getWatchedData:" <> show e

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Operation

instance giA :: GetIcons (ExceptT Error Aff) where
  getIconsData {db} _ = do
    result <- liftAff $ Sunde.spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ case result.exit of
      Normally 0 -> {success: true}
      _ -> {success: false}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA :: UpdateWatched (ExceptT Error Aff) where
  updateWatched config@{db} ur = do
    let params = {"$path": unwrap ur.path}
    _ <- liftAff $ if ur.watched
      then do
        let
          fields =
            { path: SProxy :: SProxy "$path"
            , created: SProxy :: SProxy "datetime()"
            }
          template = SProxy :: SProxy "insert or replace into watched ({fields}) values ({values})"
          query = formatSymbol template
            { fields: intercalateRowLabels fields (SProxy :: SProxy ", ")
            , values: intercalateRowValues fields (SProxy :: SProxy ", ")
            }
        void $ J.queryDB db query params
      else do
        let queryString = SProxy :: SProxy "delete from watched where path = $path"
        void $ J.queryDB db queryString params
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Operation)

instance ofA :: OpenFile (ExceptT Error Aff) where
  openFile {dir, exe} or = do
    let
      simpleOpen = case exe, platform of
        exe', _ | exe' /= "" -> Just exe'
        _, Just Linux -> Just "xdg-open"
        _, Just Darwin -> Just "open"
        _, _ -> Nothing
    _ <- liftAff $ case simpleOpen of
          Just command -> liftEffect $ void $ spawn command (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEffect $ void $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ {success: true}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Operation)

instance rfA :: RemoveFile (ExceptT Error Aff) where
  removeFile {dir} rr = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ {success: true}

ensureDB :: FilePath -> Aff DBConnection
ensureDB path = do
  db <- newDB path
  _ <- SQL.queryDB db "create table if not exists watched (path text primary key unique, created datetime)" []
  pure db

registerRoutes :: forall routes handlers routesL
   . RowToList routes routesL
  => RoutesHandlers routesL routes handlers
  => Record routes
  -> Record handlers
  -> M.App
  -> Effect Unit
registerRoutes = registerRoutesImpl (RLProxy :: RLProxy routesL)

class RoutesHandlers
  (routesL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  | routesL -> routes handlers
  where
    registerRoutesImpl :: forall proxy
       . proxy routesL
      -> Record routes
      -> Record handlers
      -> M.App
      -> Effect Unit

instance routesHandlersNil :: RoutesHandlers Nil routes handlers where
  registerRoutesImpl _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers tail routes handlers
  , IsSymbol name
  , Row.Cons name handler handlers' handlers
  , Row.Cons name route routes' routes
  , RegisterHandler route handler
  ) => RoutesHandlers (Cons name route tail) routes handlers where
  registerRoutesImpl _ routes handlers app = do
    registerHandlerImpl (Record.get nameP routes) (Record.get nameP handlers) app
    registerRoutesImpl (RLProxy :: RLProxy tail) routes handlers app
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler
  | route -> handler
  where
    registerHandlerImpl :: route -> handler -> M.App -> Effect Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> ExceptT Error Aff res)
         where
  registerHandlerImpl route handler app =
    M.post (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' req res = do
        body <- M.getBody req
        launchAff_ do
          {status, response} <- prepareResult <$> runExceptT do
            r :: req <- except <<< lmap (UserError <<< show) $ read body
            handler r
          liftEffect do
            M.setStatus status res
            M.sendResponse response res

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (ExceptT Error Aff res)
         where
  registerHandlerImpl route handler app =
    M.get (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' _ res = launchAff_ do
        {status, response} <- prepareResult <$> runExceptT handler
        liftEffect do
          M.setStatus status res
          M.sendResponse response res

main :: Effect Unit
main = launchAff_ do
  dir' <- parsellIni <$> readTextFile UTF8 "./config.ini"
  case dir' of
    Left e -> log $ "We broke: " <> show e
    Right ({vidtracker} :: C.Config) -> do
      db <- ensureDB $ concat [vidtracker.dir, "filetracker"]
      let config = Record.merge vidtracker {db}
      _ <- liftEffect do
        app <- M.makeApp

        middlewares <- sequence
          [ M.makeJSONMiddleware {}
          , M.makeStaticMiddleware (M.Path "dist") {}
          ]
        traverse_ (flip (M.use (M.Path "/")) app) middlewares

        registerRoutes
          apiRoutes
          { files: getFiles config
          , watched: getWatchedData config
          , getIcons: getIconsData config
          , update: updateWatched config
          , open: openFile config
          , remove: removeFile config
          }
          app

        _ <- M.listen (M.Port 3000) (log "Started server") app
        pure unit
      pure unit

module Main where

import Prelude

import Config as C
import Control.Monad.Except (ExceptT, except, runExceptT, throwError)
import Data.Array (filter, sortBy)
import Data.Bifunctor (lmap)
import Data.Either (Either(Left, Right))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse, traverse_)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Effect (Effect)
import Effect.Aff (Aff, attempt, launchAff_)
import Effect.Aff.Class (liftAff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Jajanmen as J
import Makkori as M
import Node.Buffer (Buffer, create, writeString)
import Node.ChildProcess (Exit(..), defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.FS.Aff (mkdir, readTextFile, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (platform)
import Prim.Row as Row
import Record as Record
import Routes (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, FilePath, newDB)
import SQLite3 as SQL
import Shoronpo (formatSymbol, intercalateRecordLabels, intercalateRowLabels, intercalateRowValues)
import Simple.JSON (class ReadForeign, class WriteForeign, read, writeJSON)
import Sunde as Sunde
import Tortellini (parsellIni)
import Type.Prelude (class RowToList, Proxy(..), RLProxy(RLProxy))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData, GetIconsRequest, OpenRequest, Operation, Path(Path), RemoveRequest, WatchedData)

data Error
  = ServerError String
  | UserError String

prepareResult :: forall a. WriteForeign a => Either Error a -> {status :: Int, response :: String}
prepareResult (Left (UserError error)) = {status: 400, response: writeJSON {error}}
prepareResult (Left (ServerError error)) = {status: 500, response: writeJSON {error}}
prepareResult (Right result) = {status: 200, response: writeJSON result}

readdir' :: String -> Aff (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: Int -> String -> Effect Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

type Config =
  { db :: DBConnection
  , dir :: String
  , exe :: String
  }

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF :: GetFiles (ExceptT Error Aff) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA :: GetWatched (ExceptT Error Aff) where
  getWatchedData {db} = do
    let
      template = SProxy :: SProxy "select {columns} from watched"
      query = formatSymbol template
        { columns: intercalateRecordLabels (Proxy :: Proxy WatchedData) (SProxy :: SProxy ", ") }
    results <- liftAff $ J.queryDB db query {}
    case read results of
      Right xs -> do
        pure xs
      Left e -> do
        throwError <<< ServerError $ "getWatchedData:" <> show e

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Operation

instance giA :: GetIcons (ExceptT Error Aff) where
  getIconsData {db} _ = do
    result <- liftAff $ Sunde.spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ case result.exit of
      Normally 0 -> {success: true}
      _ -> {success: false}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA :: UpdateWatched (ExceptT Error Aff) where
  updateWatched config@{db} ur = do
    let params = {"$path": unwrap ur.path}
    _ <- liftAff $ if ur.watched
      then do
        let
          fields =
            { path: SProxy :: SProxy "$path"
            , created: SProxy :: SProxy "datetime()"
            }
          template = SProxy :: SProxy "insert or replace into watched ({fields}) values ({values})"
          query = formatSymbol template
            { fields: intercalateRowLabels fields (SProxy :: SProxy ", ")
            , values: intercalateRowValues fields (SProxy :: SProxy ", ")
            }
        void $ J.queryDB db query params
      else do
        let queryString = SProxy :: SProxy "delete from watched where path = $path"
        void $ J.queryDB db queryString params
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Operation)

instance ofA :: OpenFile (ExceptT Error Aff) where
  openFile {dir, exe} or = do
    let
      simpleOpen = case exe, platform of
        exe', _ | exe' /= "" -> Just exe'
        _, Just Linux -> Just "xdg-open"
        _, Just Darwin -> Just "open"
        _, _ -> Nothing
    _ <- liftAff $ case simpleOpen of
          Just command -> liftEffect $ void $ spawn command (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEffect $ void $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ {success: true}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Operation)

instance rfA :: RemoveFile (ExceptT Error Aff) where
  removeFile {dir} rr = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ {success: true}

ensureDB :: FilePath -> Aff DBConnection
ensureDB path = do
  db <- newDB path
  _ <- SQL.queryDB db "create table if not exists watched (path text primary key unique, created datetime)" []
  pure db

registerRoutes :: forall routes handlers routesL
   . RowToList routes routesL
  => RoutesHandlers routesL routes handlers
  => Record routes
  -> Record handlers
  -> M.App
  -> Effect Unit
registerRoutes = registerRoutesImpl (RLProxy :: RLProxy routesL)

class RoutesHandlers
  (routesL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  | routesL -> routes handlers
  where
    registerRoutesImpl :: forall proxy
       . proxy routesL
      -> Record routes
      -> Record handlers
      -> M.App
      -> Effect Unit

instance routesHandlersNil :: RoutesHandlers Nil routes handlers where
  registerRoutesImpl _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers tail routes handlers
  , IsSymbol name
  , Row.Cons name handler handlers' handlers
  , Row.Cons name route routes' routes
  , RegisterHandler route handler
  ) => RoutesHandlers (Cons name route tail) routes handlers where
  registerRoutesImpl _ routes handlers app = do
    registerHandlerImpl (Record.get nameP routes) (Record.get nameP handlers) app
    registerRoutesImpl (RLProxy :: RLProxy tail) routes handlers app
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler
  | route -> handler
  where
    registerHandlerImpl :: route -> handler -> M.App -> Effect Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> ExceptT Error Aff res)
         where
  registerHandlerImpl route handler app =
    M.post (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' req res = do
        body <- M.getBody req
        launchAff_ do
          {status, response} <- prepareResult <$> runExceptT do
            r :: req <- except <<< lmap (UserError <<< show) $ read body
            handler r
          liftEffect do
            M.setStatus status res
            M.sendResponse response res

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (ExceptT Error Aff res)
         where
  registerHandlerImpl route handler app =
    M.get (M.Path route') (M.makeHandler handler') app
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' _ res = launchAff_ do
        {status, response} <- prepareResult <$> runExceptT handler
        liftEffect do
          M.setStatus status res
          M.sendResponse response res

main :: Effect Unit
main = launchAff_ do
  dir' <- parsellIni <$> readTextFile UTF8 "./config.ini"
  case dir' of
    Left e -> log $ "We broke: " <> show e
    Right ({vidtracker} :: C.Config) -> do
      db <- ensureDB $ concat [vidtracker.dir, "filetracker"]
      let config = Record.merge vidtracker {db}
      _ <- liftEffect do
        app <- M.makeApp

        middlewares <- sequence
          [ M.makeJSONMiddleware {}
          , M.makeStaticMiddleware (M.Path "dist") {}
          ]
        traverse_ (flip (M.use (M.Path "/")) app) middlewares

        registerRoutes
          apiRoutes
          { files: getFiles config
          , watched: getWatchedData config
          , getIcons: getIconsData config
          , update: updateWatched config
          , open: openFile config
          , remove: removeFile config
          }
          app

        _ <- M.listen (M.Port 3000) (log "Started server") app
        pure unit
      pure unit


fixed syntax error

fixed syntax error

module Main where

import Prelude hiding (div, top, bottom)
import Types
import Lenses (tab, message)
import Save (getSavedState, saveState)
import Reset (resetSave, resetState)
import Age (ageDescription)
import Util (schedule, mkClass, renderParagraphs)

import Data.Lens (set)
import Data.Tuple (Tuple(..))
import Data.String (null)
import Data.Functor ((<$))
import Data.Date (nowEpochMilliseconds)

import Control.Monad.Aff (Aff(), runAff, later)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException)
import Control.Monad.Eff.Console (log)

import Halogen
  ( Component(), component
  , Eval(), Render()
  , runUI, modify, action, get, gets, liftEff', liftAff'
  )
import Halogen.Util (appendToBody, onLoad)
import Halogen.Component (ComponentHTML())
import Halogen.HTML.Indexed (div, div_, h1, h3_, h3, text, br_, a, span, p_, img)
import Halogen.HTML.Events.Indexed (onMouseDown, input_)
import Halogen.HTML.Properties.Indexed (id_, href, src, alt)

import Age.Stone.Render (advanceComponent, upgradesComponent, side) as Stone
import Age.Stone.Eval (advance, autoclick, buyUpgrade, evalClick) as Stone
import Age.Bronze.Eval (autoclick, evalClick) as Bronze
import Age.Bronze.Render (advanceComponent, populationComponent, upgradesComponent, side, sufferingClass) as Bronze
import Disaster.Bronze (suffer) as Bronze

interface :: Component State Action (Aff AppEffects)
interface = component render eval

render :: Render State Action
render state =
  div
    [ id_ "body", mkClass $ show state.age ++ " " ++ adjustBody state ]
    [ a
      [ href "https://github.com/thimoteus/clicker-builder"
      , id_ "fork-me" ]
      [ img
        [ src "https://camo.githubusercontent.com/365986a132ccd6a44c23a9169022c0b5c890c387/68747470733a2f2f73332e616d617a6f6e6177732e636f6d2f6769746875622f726962626f6e732f666f726b6d655f72696768745f7265645f6161303030302e706e67"
        , alt "Fork me on Github" ]
      ]
    , div
      [ id_ "container" ]
      [ top
      , side
      , main'
      , bottom
      ]
    ]
  where
    top =
      h1 [ id_ "title" ]
         [ text "clicker builder: the "
         , span [ mkClass $ show state.age ] [ text $ show state.age ]
         , text " Age." ]
    side =
      div
        [ id_ "side" ]
        [ viewSide state
        , br_
        , span
          [ onMouseDown $ input_ Save
          , mkClass "button" ]
          [ text "Save" ]
        , divider
        , span
          [ onMouseDown $ input_ Reset
          , mkClass "button" ]
          [ text "Reset" ]
        ]
    main' =
      div
        [ id_ "main" ]
        [ div
          [ id_ "view" ]
          [ unlockViewTabs state
          , viewTabs state
          ]
        , if null state.message
             then
               div_
                 []
             else
               div
                 [ mkClass "fade messages" ]
                 [ text state.message ]
        ]
    bottom = div [ id_ "bottom" ]
      [ h3_ [ text "The story so far:" ]
      , renderParagraphs $ ageDescription state.age
      , h3_ [ text "Changelog" ]
      , renderParagraphs
        [ "Bronze age implemented, population, disasters, graphics" ]
      , h3_ [ text "Upcoming" ]
      , p_ [ text "Iron Age, heroes." ]
      , h3_ [ text "Credits" ]
      , renderParagraphs
        [ "Font: Silkscreen by Jason Kottke.", "Icons: fontawesome by Dave Gandy.", "Ideas and feedback: Himrin." ]
      ]

adjustBody :: State → String
adjustBody state =
  case state.age of
       Stone → ""
       Bronze → Bronze.sufferingClass state
       _ → "" -- FIXME

viewSide :: Render State Action
viewSide state =
  case state.age of
       Stone -> Stone.side state
       Bronze -> Bronze.side state
       _ -> Stone.side state --FIXME

unlockViewTabs :: Render State Action
unlockViewTabs state =
  h3 [ mkClass "title" ]
  ([ span
    [ mkClass "tab"
    , onMouseDown $ input_ $ View UpgradesTab ]
    [ text $ show UpgradesTab ]
  , divider
  , span
    [ mkClass "tab"
    , onMouseDown $ input_ $ View AdvanceTab ]
    [ text $ show AdvanceTab ]] ++ tabByAge state.age)
      where
      tabByAge :: Age -> Array (ComponentHTML Action)
      tabByAge Stone = []
      tabByAge Bronze = [ divider
                        , span [ mkClass "tab"
                               , onMouseDown $ input_ $ View PopulationTab ]
                               [ text $ show PopulationTab ]
                        ]
      tabByAge _ = tabByAge Bronze
                ++ [ divider
                   , span [ mkClass "tab" ] [ text $ show TechTreeTab ]]

divider :: ComponentHTML Action
divider = span [ mkClass "divide" ] [ text " | " ]

viewTabs :: Render State Action
viewTabs state =
  case state.view of
       UpgradesTab -> upgradesComponent state
       AdvanceTab -> advanceComponent state
       PopulationTab -> populationComponent state
       HeroesTab -> heroesComponent state
       TechTreeTab -> techTreeComponent state

upgradesComponent :: Render State Action
upgradesComponent state =
  case state.age of
       Stone -> Stone.upgradesComponent state
       Bronze -> Bronze.upgradesComponent state
       _ -> Stone.upgradesComponent state -- FIXME

populationComponent :: Render State Action
populationComponent state =
  case state.age of
       Bronze → Bronze.populationComponent state
       _ -> text ""

advanceComponent :: Render State Action
advanceComponent state =
  case state.age of
       Stone -> Stone.advanceComponent state
       Bronze -> Bronze.advanceComponent state
       _ -> Stone.advanceComponent state --FIXME

heroesComponent :: Render State Action
heroesComponent state =
  div_
    [ div [ mkClass "heroes" ]
      [ text ""
      ]
    ]

techTreeComponent :: Render State Action
techTreeComponent state =
  div_
    [ div [ mkClass "techTree" ]
      [ text ""
      ]
    ]

eval :: Eval Action State Action (Aff AppEffects)
eval (Click next) = next <$ do
  currentState <- get
  modify case currentState.age of
              Stone -> Stone.evalClick
              Bronze -> Bronze.evalClick
              _ -> Stone.evalClick --FIXME
eval (Buy upgrade next) = next <$ do
  modify $ set message ""
  liftAff' $ later $ pure unit :: Aff AppEffects Unit
  currentState <- get
  modify case currentState.age of
              Stone -> Stone.buyUpgrade upgrade
              _ -> Stone.buyUpgrade upgrade --FIXME
eval (Suffer disaster next) = next <$ do
  currentAge <- gets _.age
  modify case currentAge of
              Bronze -> Bronze.suffer disaster
              _ -> id
eval (Autoclick next) = next <$ do
  currentAge <- gets _.age
  currentTime <- liftEff' nowEpochMilliseconds
  modify case currentAge of
              Stone -> Stone.autoclick currentTime
              Bronze -> Bronze.autoclick currentTime
              _ -> Stone.autoclick currentTime
eval (Reset next) = next <$ do
  modify resetState
  liftEff' resetSave
eval (Save next) = next <$ do
  currentState <- get
  modify $ set message ""
  liftAff' $ later $ pure unit :: Aff AppEffects Unit
  liftEff' $ saveState currentState
  modify $ set message "Game saved"
eval (Autosave next) = next <$ do
  currentState <- get
  liftEff' $ log "Autosaving game ... "
  liftEff' $ saveState currentState
eval (View t next) = next <$ modify (set tab t)
eval (Advance next) = next <$ do
  currentAge <- gets _.age
  modify case currentAge of
              Stone -> Stone.advance
              _ -> Stone.advance --FIXME

main :: Eff AppEffects Unit
main = runAff throwException (const $ pure unit) do
  savedState <- liftEff getSavedState
  app <- runUI interface savedState
  onLoad $ appendToBody app.node
  schedule [ Tuple 100 $ app.driver $ action Autoclick
           , Tuple 15000 $ app.driver $ action Autosave ]

module Main where

import Prelude hiding (div, top, bottom)
import Types
import Lenses (tab, message)
import Save (getSavedState, saveState)
import Reset (resetSave, resetState)
import Age (ageDescription)
import Util (schedule, mkClass, renderParagraphs)

import Data.Lens (set)
import Data.Tuple (Tuple(..))
import Data.String (null)
import Data.Functor ((<$))
import Data.Date (nowEpochMilliseconds)

import Control.Monad.Aff (Aff(), runAff, later)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException)
import Control.Monad.Eff.Console (log)

import Halogen
  ( Component(), component
  , Eval(), Render()
  , runUI, modify, action, get, gets, liftEff', liftAff'
  )
import Halogen.Util (appendToBody, onLoad)
import Halogen.Component (ComponentHTML())
import Halogen.HTML.Indexed (div, div_, h1, h3_, h3, text, br_, a, span, p_, img)
import Halogen.HTML.Events.Indexed (onMouseDown, input_)
import Halogen.HTML.Properties.Indexed (id_, href, src, alt)

import Age.Stone.Render (advanceComponent, upgradesComponent, side) as Stone
import Age.Stone.Eval (advance, autoclick, buyUpgrade, evalClick) as Stone
import Age.Bronze.Eval (autoclick, evalClick) as Bronze
import Age.Bronze.Render (advanceComponent, populationComponent, upgradesComponent, side, sufferingClass) as Bronze
import Disaster.Bronze (suffer) as Bronze

interface :: Component State Action (Aff AppEffects)
interface = component render eval

render :: Render State Action
render state =
  div
    [ id_ "body", mkClass $ show state.age ++ " " ++ adjustBody state ]
    [ a
      [ href "https://github.com/thimoteus/clicker-builder"
      , id_ "fork-me" ]
      [ img
        [ src "https://camo.githubusercontent.com/365986a132ccd6a44c23a9169022c0b5c890c387/68747470733a2f2f73332e616d617a6f6e6177732e636f6d2f6769746875622f726962626f6e732f666f726b6d655f72696768745f7265645f6161303030302e706e67"
        , alt "Fork me on Github" ]
      ]
    , div
      [ id_ "container" ]
      [ top
      , side
      , main'
      , bottom
      ]
    ]
  where
    top =
      h1 [ id_ "title" ]
         [ text "clicker builder: the "
         , span [ mkClass $ show state.age ] [ text $ show state.age ]
         , text " Age." ]
    side =
      div
        [ id_ "side" ]
        [ viewSide state
        , br_
        , span
          [ onMouseDown $ input_ Save
          , mkClass "button" ]
          [ text "Save" ]
        , divider
        , span
          [ onMouseDown $ input_ Reset
          , mkClass "button" ]
          [ text "Reset" ]
        ]
    main' =
      div
        [ id_ "main" ]
        [ div
          [ id_ "view" ]
          [ unlockViewTabs state
          , viewTabs state
          ]
        , if null state.message
             then
               div_
                 []
             else
               div
                 [ mkClass "fade messages" ]
                 [ text state.message ]
        ]
    bottom = div [ id_ "bottom" ]
      [ h3_ [ text "The story so far:" ]
      , renderParagraphs $ ageDescription state.age
      , h3_ [ text "Changelog" ]
      , renderParagraphs
        [ "Bronze age implemented, population, disasters, graphics" ]
      , h3_ [ text "Upcoming" ]
      , p_ [ text "Iron Age, heroes." ]
      , h3_ [ text "Credits" ]
      , renderParagraphs
        [ "Font: Silkscreen by Jason Kottke.", "Icons: fontawesome by Dave Gandy.", "Ideas and feedback: Himrin." ]
      ]

adjustBody :: State → String
adjustBody state =
  case state.age of
       Stone → ""
       Bronze → Bronze.sufferingClass state
       _ → "" -- FIXME

viewSide :: Render State Action
viewSide state =
  case state.age of
       Stone -> Stone.side state
       Bronze -> Bronze.side state
       _ -> Stone.side state --FIXME

unlockViewTabs :: Render State Action
unlockViewTabs state =
  h3 [ mkClass "title" ]
  ([ span
    [ mkClass "tab"
    , onMouseDown $ input_ $ View UpgradesTab ]
    [ text $ show UpgradesTab ]
  , divider
  , span
    [ mkClass "tab"
    , onMouseDown $ input_ $ View AdvanceTab ]
    [ text $ show AdvanceTab ]] ++ tabByAge state.age)
      where
      tabByAge :: Age -> Array (ComponentHTML Action)
      tabByAge Stone = []
      tabByAge Bronze = [ divider
                        , span [ mkClass "tab"
                               , onMouseDown $ input_ $ View PopulationTab ]
                               [ text $ show PopulationTab ]
                        ]
      tabByAge _ = tabByAge Bronze
                ++ [ divider
                   , span [ mkClass "tab" ] [ text $ show TechTreeTab ]]

divider :: ComponentHTML Action
divider = span [ mkClass "divide" ] [ text " | " ]

viewTabs :: Render State Action
viewTabs state =
  case state.view of
       UpgradesTab -> upgradesComponent state
       AdvanceTab -> advanceComponent state
       PopulationTab -> populationComponent state
       HeroesTab -> heroesComponent state
       TechTreeTab -> techTreeComponent state

upgradesComponent :: Render State Action
upgradesComponent state =
  case state.age of
       Stone -> Stone.upgradesComponent state
       Bronze -> Bronze.upgradesComponent state
       _ -> Stone.upgradesComponent state -- FIXME

populationComponent :: Render State Action
populationComponent state =
  case state.age of
       Bronze → Bronze.populationComponent state
       _ -> text ""

advanceComponent :: Render State Action
advanceComponent state =
  case state.age of
       Stone -> Stone.advanceComponent state
       Bronze -> Bronze.advanceComponent state
       _ -> Stone.advanceComponent state --FIXME

heroesComponent :: Render State Action
heroesComponent state =
  div_
    [ div [ mkClass "heroes" ]
      [ text ""
      ]
    ]

techTreeComponent :: Render State Action
techTreeComponent state =
  div_
    [ div [ mkClass "techTree" ]
      [ text ""
      ]
    ]

eval :: Eval Action State Action (Aff AppEffects)
eval (Click next) = next <$ do
  currentState <- get
  modify case currentState.age of
              Stone -> Stone.evalClick
              Bronze -> Bronze.evalClick
              _ -> Stone.evalClick --FIXME
eval (Buy upgrade next) = next <$ do
  modify $ set message ""
  liftAff' $ later $ pure unit :: Aff AppEffects Unit
  currentState <- get
  modify case currentState.age of
              Stone -> Stone.buyUpgrade upgrade
              _ -> Stone.buyUpgrade upgrade --FIXME
eval (Suffer disaster next) = next <$ do
  currentAge <- gets _.age
  modify case currentAge of
              Bronze -> Bronze.suffer disaster
              _ -> id
eval (Autoclick next) = next <$ do
  currentAge <- gets _.age
  currentTime <- liftEff' nowEpochMilliseconds
  modify case currentAge of
              Stone -> Stone.autoclick currentTime
              Bronze -> Bronze.autoclick currentTime
              _ -> Stone.autoclick currentTime
eval (Reset next) = next <$ do
  modify resetState
  liftEff' resetSave
eval (Save next) = next <$ do
  currentState <- get
  modify $ set message ""
  liftAff' $ later $ pure unit :: Aff AppEffects Unit
  liftEff' $ saveState currentState
  modify $ set message "Game saved"
eval (Autosave next) = next <$ do
  currentState <- get
  liftEff' $ log "Autosaving game ... "
  liftEff' $ saveState currentState
eval (View t next) = next <$ modify (set tab t)
eval (Advance next) = next <$ do
  currentAge <- gets _.age
  modify case currentAge of
              Stone -> Stone.advance
              _ -> Stone.advance --FIXME

main :: Eff AppEffects Unit
main = runAff throwException (const $ pure unit) do
  savedState <- liftEff getSavedState
  app <- runUI interface savedState
  onLoad $ appendToBody app.node
  schedule [ Tuple 100 $ app.driver $ action Autoclick ]
           , Tuple 15000 $ app.driver $ action Autosave ]


Reduce complexity of patterns to speed up build

module Evaluator where

import Prelude (class Show, class Semigroup, Unit, Ordering(..), (++), ($), unit, return, (<*>), (<$>), pure, void, (==), otherwise, (>>=), (<), negate, (>), (>=), (<=), (/=), (-), (+), mod, div, (*), (<<<), compare, id, const, bind, show)
import Data.List (List(Nil, Cons), singleton, concatMap, intersect, zipWithA, length, (:), replicate, drop, updateAt, (!!))
import Data.StrMap (StrMap)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(..))
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity, runIdentity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import Control.Monad.State.Trans (StateT, modify, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..))

data EvalError =
    PathError Path Expr
  | IndexError Int Int
  | DivByZero
  | EvalError Expr
  | BinaryOpError Op Expr Expr
  | UnaryOpError Op Expr
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | CannotEvaluate Expr
  | NoError
  | MoreErrors EvalError EvalError

instance semigroupEvalError :: Semigroup EvalError where
  append e1 e2 = MoreErrors e1 e2

instance monoidEvalError :: Monoid EvalError where
  mempty = NoError

instance showEvalError :: Show EvalError where
  show (PathError p e)            = "PathError " ++ show p ++ " " ++ show e
  show (IndexError i l)           = "IndexError " ++ show i ++ " " ++ show l
  show DivByZero                  = "DivByZero"
  show (EvalError e)              = "EvalError " ++ show e
  show (BinaryOpError o e1 e2)    = "BinaryOpError " ++ show o ++ " (" ++ show e1 ++ ") (" ++ show e2 ++ ")"
  show (UnaryOpError o e)         = "UnaryOpError " ++ show o ++ " " ++ show e
  show (NameCaptureError ns)      = "NameCaptureError " ++ show ns
  show (UnknownFunction n)        = "UnknownFunction " ++ show n
  show (NoMatchingFunction n mes) = "NoMatchingFunction " ++ show n ++ " " ++ show mes
  show (CannotEvaluate e)         = "CannotEvaluate " ++ show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " ++ show e1 ++ " " ++ show e2 ++ ")"

data MatchingError =
    MatchingError Binding Expr
  | StrictnessError Binding Expr
  | TooFewArguments (List Binding) (List Expr)

instance showMatchingError :: Show MatchingError where
  show (MatchingError b e)     = "MatchingError " ++ show b ++ " " ++ show e
  show (StrictnessError b e)   = "StrictnessError " ++ show b ++ " " ++ show e
  show (TooFewArguments bs es) = "TooFewArguments " ++ show bs ++ " " ++ show es

type Evaluator = ExceptT EvalError Identity

runEvalM :: forall a. Evaluator a -> Either EvalError a
runEvalM = runIdentity <<< runExceptT

type Matcher = ExceptT MatchingError Identity

runMatcherM :: forall a. Matcher a -> Either MatchingError a
runMatcherM = runIdentity <<< runExceptT

data Path = Nth Int Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    Thrd   p -> "(Thrd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr <$> go p ce <*> pure te <*> pure ee
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ PathError (Fst p) e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ PathError (Snd p) e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ PathError (Thrd p) e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ PathError (Nth n p) e

mapIndex :: forall a. Int -> (a -> Evaluator a) -> (List a) -> Evaluator (List a)
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ IndexError i (length as)
    Just a  -> do
      a' <- f a
      case updateAt i a' as of
        Nothing  -> throwError $ IndexError i (length as)
        Just as' -> return as'

evalPath1 :: Env -> Path -> Expr -> Either EvalError Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

type Env = StrMap (List (Tuple (List Binding) Expr))

defsToEnv :: (List Definition) -> Env
defsToEnv = foldl insertDef Map.empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case Map.lookup name env of
  Nothing   -> Map.insert name (singleton $ Tuple bindings body) env
  Just defs -> Map.insert name (defs ++ (singleton $ Tuple bindings body)) env

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name Nil
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) (Cons e Nil)) -> return $ App f (singleton $ App g (Cons e Nil))
  (App (Lambda binds body) args)     -> tryAll (singleton $ Tuple binds body) args "lambda" Nil
  (App (SectL e1 op) (Cons e2 Nil))           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (SectR op e2) (Cons e1 Nil))           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (PrefixOp op) (Cons e1 (Cons e2 Nil)))         -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _                                  -> throwError $ CannotEvaluate expr

eval :: Env -> Expr -> Expr
eval env expr =
  if expr == evald
    then expr
    else eval env evald
  where
  evald :: Expr
  evald = either (const expr') id $ runEvalM $ eval1 env expr'
  expr' :: Expr
  expr' = case expr of
    (Binary op e1 e2)  ->
      Binary op (eval env e1) (eval env e2)
    (Unary op e)       ->
      Unary op (eval env e)
    (IfExpr c t e)     ->
      IfExpr (eval env c) t e
    (App f args)       -> do
      App (eval env f) args
    _                  ->
      expr

wrapLambda :: (List Binding) -> (List Expr) -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

binary :: Op -> Expr -> Expr -> Evaluator Expr
binary op = case op of
  Power  -> aint Power (\i j -> product $ replicate j i)
  Mul    -> aint Mul (*)
  Div    -> aint Div div
  Mod    -> aint Mod mod
  Add    -> aint Add (+)
  Sub    -> aint Sub (-)
  Colon  -> \e es -> case es of
    (List ls) -> return $ List $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List ls1) (List ls2)) -> return $ List $ ls1 ++ ls2
    _                             -> throwError $ BinaryOpError Append es1 es2
  Equ    -> ord Equ (==) (==) (==)
  Neq    -> ord Neq (/=) (/=) (/=)
  Leq    -> ord Leq (<=) (<=) (<=)
  Lt     -> ord Lt  (<)  (<)  (<)
  Geq    -> ord Geq (>=) (>=) (>=)
  Gt     -> ord Gt  (>)  (>)  (>)
  And    -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom (Bool false)) _                  ) -> return $ Atom $ Bool false
    (Tuple _                   (Atom (Bool false))) -> return $ Atom $ Bool false
    (Tuple (Atom (Bool true))  (Atom (Bool true)) ) -> return $ Atom $ Bool true
    (Tuple _                   _                  ) -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom (Bool true))  _                   ) -> return $ Atom $ Bool true
    (Tuple _                   (Atom (Bool true))  ) -> return $ Atom $ Bool true
    (Tuple (Atom (Bool false))  (Atom (Bool false))) -> return $ Atom $ Bool false
    (Tuple _                   _                   ) -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> return $ App f (singleton e))
  Composition -> \e1 e2 -> throwError $ BinaryOpError And e1 e2
  where
    aint :: Op -> (Int -> Int -> Int) -> Expr -> Expr -> Evaluator Expr
    aint Div f (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
    aint Mod f (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
    aint _   f (Atom (AInt i)) (Atom (AInt j)) = return $ Atom $ AInt $ f i j
    aint op  _ e1              e2              = throwError $ BinaryOpError op e1 e2

    ord :: Op -> (Int -> Int -> Boolean) -> (String -> String -> Boolean) -> (Boolean -> Boolean -> Boolean)-> Expr -> Expr -> Evaluator Expr
    ord _  fi _  _  (Atom (AInt i))  (Atom (AInt j))  = return $ Atom $ Bool $ fi i j
    ord _  _  fs _  (Atom (Char s1)) (Atom (Char s2)) = return $ Atom $ Bool $ fs s1 s2
    ord _  _  _  fb (Atom (Bool b1)) (Atom (Bool b2)) = return $ Atom $ Bool $ fb b1 b2
    ord op _  _  _  e1               e2               = throwError $ BinaryOpError op e1 e2

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (AInt i)) = return $ Atom $ AInt (-i)
unary op e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List Expr) -> Evaluator Expr
apply env name args = case Map.lookup name env of
  Nothing    -> throwError $ UnknownFunction name
  Just cases -> tryAll cases args name Nil

tryAll :: (List (Tuple (List Binding) Expr)) -> (List Expr) -> String -> (List MatchingError) -> Evaluator Expr
tryAll Nil                        _    name errs = throwError $ NoMatchingFunction name errs
tryAll (Cons (Tuple binds body) cases) args name errs | (length args) < (length binds) = tryAll cases args name (errs ++ (singleton $ TooFewArguments binds args))
tryAll (Cons (Tuple binds body) cases) args name errs = case runMatcherM $ matchls' binds args of
  Right replMap                 -> replace' replMap body >>= wrapLambda binds args
  Left se@(StrictnessError _ _) -> throwError $ NoMatchingFunction name (errs ++ singleton se)
  Left err                      -> tryAll cases args name (errs ++ singleton err)

whnf :: Expr -> Boolean
whnf (Atom (Name _)) = false
whnf (Atom _)        = true
whnf (List _)        = true
whnf (NTuple _)      = true
whnf _               = false

checkStrictness :: Binding -> Expr -> MatchingError
checkStrictness bs es | whnf es   = MatchingError bs es
                      | otherwise = StrictnessError bs es

matchls' :: (List Binding) -> (List Expr) -> Matcher (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) Map.empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Matcher Unit
match' (Lit (Name name)) e                   = modify (Map.insert name e)
match' (Lit ba)          (Atom ea)           = case ba == ea of
                                                 true  -> return unit
                                                 false -> throwError $ MatchingError (Lit ba) (Atom ea)
match' (Lit b)           e                   = throwError $ checkStrictness (Lit b) e

match' (ConsLit b bs)    (Binary Colon e es)  = match' b e *> match' bs es
match' (ConsLit b bs)    (List (Cons e es))  = match' (ConsLit b bs) (Binary Colon e (List es))
match' (ConsLit b bs)    (List Nil)           = throwError $ MatchingError (ConsLit b bs) (List Nil)
match' (ConsLit b bs)    e                   = throwError $ checkStrictness (ConsLit b bs) e

match' (ListLit (Cons b bs))  (Binary Colon e es)  = match' b e *> match' (ListLit bs) es
match' (ListLit bs)      (List es)           = case length bs == length es of
                                                 true  -> void $ zipWithA match' bs es
                                                 false -> throwError $ MatchingError (ListLit bs) (List es)
match' (ListLit bs)      e                   = throwError $ checkStrictness (ListLit bs) e

match' (NTupleLit bs)    (NTuple es)         = case length bs == length es of
                                                 true  -> void $ zipWithA match' bs es
                                                 false -> throwError $ MatchingError (NTupleLit bs) (NTuple es)
match' (NTupleLit bs)    e                   = throwError $ checkStrictness (NTupleLit bs) e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case Map.lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (IfExpr ce te ee)    -> IfExpr <$> go ce <*> go te <*> go ee
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> (List Binding) -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ Map.values subs) (boundNames' binds) of
  Nil       -> return unit
  captures -> throwError $ NameCaptureError captures

freeVariables :: Expr -> (List String)
freeVariables _ = Nil
-- freeVariables = nub <<< foldExpr
--   (\a -> case a of
--     Name name -> singleton $ name
--     _         -> Nil)
--   concat
--   concat
--   (\_ f1 f2 -> f1 ++ f2)
--   (\_ f -> f)
--   (\f _ -> f)
--   (\_ f -> f)
--   (\_ -> Nil)
--   (\f1 f2 f3 -> f1 ++ f2 ++ f3)
--   (\bs f -> nub f \\ boundNames' bs)
--   (\f fs -> f ++ concat fs)

boundNames' :: (List Binding) -> (List String)
boundNames' = concatMap boundNames

boundNames :: Binding -> (List String)
boundNames = go
  where
  go (Lit (Name name)) = singleton name
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs
  go _                 = Nil

module Evaluator where

import Prelude (class Show, class Semigroup, Unit, Ordering(..), (++), ($), unit, return, (<*>), (<$>), pure, void, (==), otherwise, (>>=), (<), negate, (>), (>=), (<=), (/=), (-), (+), mod, div, (*), (<<<), compare, id, const, bind, show)
import Data.List (List(Nil, Cons), singleton, concatMap, intersect, zipWithA, length, (:), replicate, drop, updateAt, (!!))
import Data.StrMap (StrMap)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(..))
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity, runIdentity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import Control.Monad.State.Trans (StateT, modify, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..))

data EvalError =
    PathError Path Expr
  | IndexError Int Int
  | DivByZero
  | EvalError Expr
  | BinaryOpError Op Expr Expr
  | UnaryOpError Op Expr
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | CannotEvaluate Expr
  | NoError
  | MoreErrors EvalError EvalError

instance semigroupEvalError :: Semigroup EvalError where
  append e1 e2 = MoreErrors e1 e2

instance monoidEvalError :: Monoid EvalError where
  mempty = NoError

instance showEvalError :: Show EvalError where
  show (PathError p e)            = "PathError " ++ show p ++ " " ++ show e
  show (IndexError i l)           = "IndexError " ++ show i ++ " " ++ show l
  show DivByZero                  = "DivByZero"
  show (EvalError e)              = "EvalError " ++ show e
  show (BinaryOpError o e1 e2)    = "BinaryOpError " ++ show o ++ " (" ++ show e1 ++ ") (" ++ show e2 ++ ")"
  show (UnaryOpError o e)         = "UnaryOpError " ++ show o ++ " " ++ show e
  show (NameCaptureError ns)      = "NameCaptureError " ++ show ns
  show (UnknownFunction n)        = "UnknownFunction " ++ show n
  show (NoMatchingFunction n mes) = "NoMatchingFunction " ++ show n ++ " " ++ show mes
  show (CannotEvaluate e)         = "CannotEvaluate " ++ show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " ++ show e1 ++ " " ++ show e2 ++ ")"

data MatchingError =
    MatchingError Binding Expr
  | StrictnessError Binding Expr
  | TooFewArguments (List Binding) (List Expr)

instance showMatchingError :: Show MatchingError where
  show (MatchingError b e)     = "MatchingError " ++ show b ++ " " ++ show e
  show (StrictnessError b e)   = "StrictnessError " ++ show b ++ " " ++ show e
  show (TooFewArguments bs es) = "TooFewArguments " ++ show bs ++ " " ++ show es

type Evaluator = ExceptT EvalError Identity

runEvalM :: forall a. Evaluator a -> Either EvalError a
runEvalM = runIdentity <<< runExceptT

type Matcher = ExceptT MatchingError Identity

runMatcherM :: forall a. Matcher a -> Either MatchingError a
runMatcherM = runIdentity <<< runExceptT

data Path = Nth Int Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    Thrd   p -> "(Thrd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr <$> go p ce <*> pure te <*> pure ee
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ PathError (Fst p) e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ PathError (Snd p) e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ PathError (Thrd p) e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ PathError (Nth n p) e

mapIndex :: forall a. Int -> (a -> Evaluator a) -> (List a) -> Evaluator (List a)
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ IndexError i (length as)
    Just a  -> do
      a' <- f a
      case updateAt i a' as of
        Nothing  -> throwError $ IndexError i (length as)
        Just as' -> return as'

evalPath1 :: Env -> Path -> Expr -> Either EvalError Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

type Env = StrMap (List (Tuple (List Binding) Expr))

defsToEnv :: (List Definition) -> Env
defsToEnv = foldl insertDef Map.empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case Map.lookup name env of
  Nothing   -> Map.insert name (singleton $ Tuple bindings body) env
  Just defs -> Map.insert name (defs ++ (singleton $ Tuple bindings body)) env

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name Nil
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) (Cons e Nil)) -> return $ App f (singleton $ App g (Cons e Nil))
  (App (Lambda binds body) args)     -> tryAll (singleton $ Tuple binds body) args "lambda" Nil
  (App (SectL e1 op) (Cons e2 Nil))           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (SectR op e2) (Cons e1 Nil))           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (PrefixOp op) (Cons e1 (Cons e2 Nil)))         -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _                                  -> throwError $ CannotEvaluate expr

eval :: Env -> Expr -> Expr
eval env expr =
  if expr == evald
    then expr
    else eval env evald
  where
  evald :: Expr
  evald = either (const expr') id $ runEvalM $ eval1 env expr'
  expr' :: Expr
  expr' = case expr of
    (Binary op e1 e2)  ->
      Binary op (eval env e1) (eval env e2)
    (Unary op e)       ->
      Unary op (eval env e)
    (IfExpr c t e)     ->
      IfExpr (eval env c) t e
    (App f args)       -> do
      App (eval env f) args
    _                  ->
      expr

wrapLambda :: (List Binding) -> (List Expr) -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

binary :: Op -> Expr -> Expr -> Evaluator Expr
binary = go
  where
  retA = return <<< Atom
  go Power (Atom (AInt i)) (Atom (AInt j)) = retA $ AInt $ product $ replicate j i

  go Mul (Atom (AInt i)) (Atom (AInt j)) = retA $ AInt $ i * j
  go Div (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
  go Div (Atom (AInt i)) (Atom (AInt j)) = retA $ AInt $ (i `div` j)
  go Mod (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
  go Mod (Atom (AInt i)) (Atom (AInt j)) = retA $ AInt $ i `mod` j

  go Add (Atom (AInt i)) (Atom (AInt j)) = retA $ AInt $ i + j
  go Sub (Atom (AInt i)) (Atom (AInt j)) = retA $ AInt $ i - j

  go Colon  e          (List es)  = return $ List $ e:es
  go Append (List es1) (List es2) = return $ List $ es1 ++ es2

  go Equ  (Atom a1) (Atom a2) = retA $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = retA $ Bool $ a1 /= a2
  go Leq (Atom (AInt i)) (Atom (AInt j)) = retA $ Bool $ i <= j
  go Lt  (Atom (AInt i)) (Atom (AInt j)) = retA $ Bool $ i < j
  go Geq (Atom (AInt i)) (Atom (AInt j)) = retA $ Bool $ i >= j
  go Gt  (Atom (AInt i)) (Atom (AInt j)) = retA $ Bool $ i > j

  go Leq (Atom (Char c1)) (Atom (Char c2)) = retA $ Bool $ c1 <= c2
  go Lt  (Atom (Char c1)) (Atom (Char c2)) = retA $ Bool $ c1 < c2
  go Geq (Atom (Char c1)) (Atom (Char c2)) = retA $ Bool $ c1 >= c2
  go Gt  (Atom (Char c1)) (Atom (Char c2)) = retA $ Bool $ c1 > c2

  go And (Atom (Bool true))  b = return b
  go And (Atom (Bool false)) _ = retA $ Bool $ false

  go Or  (Atom (Bool true))  _ = retA $ Bool $ true
  go Or  (Atom (Bool false)) b = return b

  go Dollar f e = return $ App f (singleton e)

  go op e1 e2 = throwError $ BinaryOpError op e1 e2

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (AInt i)) = return $ Atom $ AInt (-i)
unary op e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List Expr) -> Evaluator Expr
apply env name args = case Map.lookup name env of
  Nothing    -> throwError $ UnknownFunction name
  Just cases -> tryAll cases args name Nil

tryAll :: (List (Tuple (List Binding) Expr)) -> (List Expr) -> String -> (List MatchingError) -> Evaluator Expr
tryAll Nil                        _    name errs = throwError $ NoMatchingFunction name errs
tryAll (Cons (Tuple binds body) cases) args name errs | (length args) < (length binds) = tryAll cases args name (errs ++ (singleton $ TooFewArguments binds args))
tryAll (Cons (Tuple binds body) cases) args name errs = case runMatcherM $ matchls' binds args of
  Right replMap                 -> replace' replMap body >>= wrapLambda binds args
  Left se@(StrictnessError _ _) -> throwError $ NoMatchingFunction name (errs ++ singleton se)
  Left err                      -> tryAll cases args name (errs ++ singleton err)

whnf :: Expr -> Boolean
whnf (Atom (Name _)) = false
whnf (Atom _)        = true
whnf (List _)        = true
whnf (NTuple _)      = true
whnf _               = false

checkStrictness :: Binding -> Expr -> MatchingError
checkStrictness bs es | whnf es   = MatchingError bs es
                      | otherwise = StrictnessError bs es

matchls' :: (List Binding) -> (List Expr) -> Matcher (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) Map.empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Matcher Unit
match' (Lit (Name name)) e                   = modify (Map.insert name e)
match' (Lit ba)          (Atom ea)           = case ba == ea of
                                                 true  -> return unit
                                                 false -> throwError $ MatchingError (Lit ba) (Atom ea)
match' (Lit b)           e                   = throwError $ checkStrictness (Lit b) e

match' (ConsLit b bs)    (Binary Colon e es)  = match' b e *> match' bs es
match' (ConsLit b bs)    (List (Cons e es))  = match' (ConsLit b bs) (Binary Colon e (List es))
match' (ConsLit b bs)    (List Nil)           = throwError $ MatchingError (ConsLit b bs) (List Nil)
match' (ConsLit b bs)    e                   = throwError $ checkStrictness (ConsLit b bs) e

match' (ListLit (Cons b bs))  (Binary Colon e es)  = match' b e *> match' (ListLit bs) es
match' (ListLit bs)      (List es)           = case length bs == length es of
                                                 true  -> void $ zipWithA match' bs es
                                                 false -> throwError $ MatchingError (ListLit bs) (List es)
match' (ListLit bs)      e                   = throwError $ checkStrictness (ListLit bs) e

match' (NTupleLit bs)    (NTuple es)         = case length bs == length es of
                                                 true  -> void $ zipWithA match' bs es
                                                 false -> throwError $ MatchingError (NTupleLit bs) (NTuple es)
match' (NTupleLit bs)    e                   = throwError $ checkStrictness (NTupleLit bs) e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case Map.lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (IfExpr ce te ee)    -> IfExpr <$> go ce <*> go te <*> go ee
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> (List Binding) -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ Map.values subs) (boundNames' binds) of
  Nil       -> return unit
  captures -> throwError $ NameCaptureError captures

freeVariables :: Expr -> (List String)
freeVariables _ = Nil
-- freeVariables = nub <<< foldExpr
--   (\a -> case a of
--     Name name -> singleton $ name
--     _         -> Nil)
--   concat
--   concat
--   (\_ f1 f2 -> f1 ++ f2)
--   (\_ f -> f)
--   (\f _ -> f)
--   (\_ f -> f)
--   (\_ -> Nil)
--   (\f1 f2 f3 -> f1 ++ f2 ++ f3)
--   (\bs f -> nub f \\ boundNames' bs)
--   (\f fs -> f ++ concat fs)

boundNames' :: (List Binding) -> (List String)
boundNames' = concatMap boundNames

boundNames :: Binding -> (List String)
boundNames = go
  where
  go (Lit (Name name)) = singleton name
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs
  go _                 = Nil