secure apart from local

secure apart from local

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Chat.ServerTypes
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function (const, (<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup ((<>))
import Data.String (take)
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, liftH, modify, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events.Indexed (input_, onClick, onInput, onKeyPress, onSubmit)
import Halogen.HTML.Indexed (button, input, textarea)
import Halogen.Query (get, set)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)
import DOM(DOM)
import DOM.HTML
import DOM.HTML.Window
import DOM.HTML.Location

type State = {cur :: String , text :: Array ChatMessage, sub :: Boolean}

initial :: State
initial = {cur: "", text: [], sub: false}

data Query a = Connect a | Disconnect a | UpdateText (Array ChatMessage) a | SendMessage a | UpdateCurrent String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

onlyForKey :: forall props g ev.
  (Functor g) => Number
                   -> ({ "keyCode" :: Number
                       | props
                       }
                       -> g (Maybe ev)
                      )
                      -> { "keyCode" :: Number
                         | props
                         }
                         -> g (Maybe ev)
onlyForKey i input  = (\ (a@{keyCode}) -> (if keyCode == 13.0 then id else const Nothing) <$> input a)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadAff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur, sub} = H.div_ $
                    append (if not sub
                        then []
                        else [ H.input [ P.value cur
                                       , E.onValueInput (E.input UpdateCurrent)
                                       , E.onKeyPress  (onlyForKey 13.0 (E.input_ SendMessage))
                                       ]
                            , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]])
                        $ (\(ChatMessage t) -> H.div_ [H.text (t.userName <> ": " <> t.messageBody)]) <$> text

              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                sub <- liftH $ liftEff initSubscriber
                subscribe (chatMessages sub.messages)
                modify (\s -> s {sub = true})
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= t})
                pure a
              eval (SendMessage a) = do
                st <- get
                merr <- liftH <<< liftAff $ sendMessage st.cur
                case merr of
                    Just err -> do modify (\s ->  s {text= append [systemMessage err] s.text})
                                   pure a
                    Nothing -> do modify (\s -> s {cur = ""})
                                  pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a

data Action = Update (Array ChatMessage)
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}
websocketUrl :: forall eff. Eff (dom :: DOM | eff) String
websocketUrl = do
  l <- location =<< window
  h <- host l
  hname <- hostname l
  let p = case hname of
            "localhost" -> "ws:"
            _ -> "wss:"
  pure $ p <> "//"<> h

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL, dom ::DOM  | eff) (SubscriberData (channel :: CHANNEL, dom ::DOM | eff))
initSubscriber = do
  ch <- channel Nop
  url <- websocketUrl
  let
    c :: Config (channel :: CHANNEL, dom ::DOM | eff) Action
    c = {
        url : url <> "/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  Signal Action ->
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       )
       Unit
callback sig eff = do
    runSignal (eff <$> sig)

systemMessage :: String -> ChatMessage
systemMessage s = ChatMessage {userName: "System", messageBody: s}

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => Signal Action ->  EventSource Query g
chatMessages sig = eventSource (callback sig) (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText [systemMessage "No op"]
            ReportError -> f $ UpdateText [systemMessage "Error"]
            SubscriberLog s -> f $ UpdateText [systemMessage s]
        )
        where
            f x = pure $ action x

sendMessage :: forall eff. String -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s = do
    ebs <- runExceptT $ runReaderT (postGame s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Chat.ServerTypes
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function (const, (<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup ((<>))
import Data.String (take)
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, liftH, modify, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events.Indexed (input_, onClick, onInput, onKeyPress, onSubmit)
import Halogen.HTML.Indexed (button, input, textarea)
import Halogen.Query (get, set)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)
import DOM(DOM)
import DOM.HTML
import DOM.HTML.Window
import DOM.HTML.Location

type State = {cur :: String , text :: Array ChatMessage, sub :: Boolean}

initial :: State
initial = {cur: "", text: [], sub: false}

data Query a = Connect a | Disconnect a | UpdateText (Array ChatMessage) a | SendMessage a | UpdateCurrent String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

onlyForKey :: forall props g ev.
  (Functor g) => Number
                   -> ({ "keyCode" :: Number
                       | props
                       }
                       -> g (Maybe ev)
                      )
                      -> { "keyCode" :: Number
                         | props
                         }
                         -> g (Maybe ev)
onlyForKey i input  = (\ (a@{keyCode}) -> (if keyCode == 13.0 then id else const Nothing) <$> input a)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadAff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur, sub} = H.div_ $
                    append (if not sub
                        then []
                        else [ H.input [ P.value cur
                                       , E.onValueInput (E.input UpdateCurrent)
                                       , E.onKeyPress  (onlyForKey 13.0 (E.input_ SendMessage))
                                       ]
                            , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]])
                        $ (\(ChatMessage t) -> H.div_ [H.text (t.userName <> ": " <> t.messageBody)]) <$> text

              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                sub <- liftH $ liftEff initSubscriber
                subscribe (chatMessages sub.messages)
                modify (\s -> s {sub = true})
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= t})
                pure a
              eval (SendMessage a) = do
                st <- get
                merr <- liftH <<< liftAff $ sendMessage st.cur
                case merr of
                    Just err -> do modify (\s ->  s {text= append [systemMessage err] s.text})
                                   pure a
                    Nothing -> do modify (\s -> s {cur = ""})
                                  pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a

data Action = Update (Array ChatMessage)
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}
websocketUrl :: forall eff. Eff (dom :: DOM | eff) String
websocketUrl = do
  l <- location =<< window
  h <- host l
  prot <- protocol l
  let p = case prot of
            "http:" -> "ws:"
            "https:" -> "wss:"
            _ -> "wss:"
  pure $ p <> "//"<> h

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL, dom ::DOM  | eff) (SubscriberData (channel :: CHANNEL, dom ::DOM | eff))
initSubscriber = do
  ch <- channel Nop
  url <- websocketUrl
  let
    c :: Config (channel :: CHANNEL, dom ::DOM | eff) Action
    c = {
        url : url <> "/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  Signal Action ->
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       )
       Unit
callback sig eff = do
    runSignal (eff <$> sig)

systemMessage :: String -> ChatMessage
systemMessage s = ChatMessage {userName: "System", messageBody: s}

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => Signal Action ->  EventSource Query g
chatMessages sig = eventSource (callback sig) (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText [systemMessage "No op"]
            ReportError -> f $ UpdateText [systemMessage "Error"]
            SubscriberLog s -> f $ UpdateText [systemMessage s]
        )
        where
            f x = pure $ action x

sendMessage :: forall eff. String -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s = do
    ebs <- runExceptT $ runReaderT (postGame s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing


Reduced code needed for obtain coordinate index or square

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Coordinate -> Array Square -> Maybe Int
getCoordinateIndex coordinate = findIndex (\s -> s.coordinate == coordinate)

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing ((\i -> squares !! i) <$> (getCoordinateIndex coordinate squares))

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false ((\p -> p.player == player) <$> square.piece)

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let px = square.render + square.offset
      vx = fst px
      vy = snd px
  in vx < x && x < vx + renderSize &&
     vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> (\s -> s.coordinate) <$> grid.squares !! index
    Nothing    -> Nothing

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex from grid.squares)
      toIndex = fromJust (getCoordinateIndex to grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> highlightPiece ctx square
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

highlightPiece :: forall e. Context2D -> Square -> Eff (canvas :: Canvas | e) Unit
highlightPiece ctx square = do
  let arcPiece = { x: fst square.render + 0.5 * renderSize,
                   y: snd square.render + 0.5 * renderSize,
                   r: (renderSize / 2.0) * 0.8,
                   start: 0.0,
                   end: 2.0 * pi }
  setLineWidth highlightWidth ctx
  strokePath ctx $ arc ctx arcPiece
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    case state.selectedCoordinate of
      Nothing -> return unit
      Just coordinate -> do
        highlightPiece ctx (fromJust (getSquare state.grid.squares coordinate))
        return unit
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus (guard)
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  case getCoordinateIndex squares coordinate of
    Nothing -> Nothing
    Just index -> squares !! index

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false ((\p -> p.player == player) <$> square.piece)

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let px = square.render + square.offset
      vx = fst px
      vy = snd px
  in vx < x && x < vx + renderSize &&
     vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> (\s -> s.coordinate) <$> grid.squares !! index
    Nothing    -> Nothing

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let pixel = Tuple (toNumber ux) (toNumber uy)
          case isOnActiveSquare state.grid state.currentPlayer pixel square of
            true -> highlightPiece ctx square
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

highlightPiece :: forall e. Context2D -> Square -> Eff (canvas :: Canvas | e) Unit
highlightPiece ctx square = do
  let arcPiece = { x: fst square.render + 0.5 * renderSize,
                   y: snd square.render + 0.5 * renderSize,
                   r: (renderSize / 2.0) * 0.8,
                   start: 0.0,
                   end: 2.0 * pi }
  setLineWidth highlightWidth ctx
  strokePath ctx $ arc ctx arcPiece
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    case state.selectedCoordinate of
      Nothing -> return unit
      Just coordinate -> do
        highlightPiece ctx (fromJust (getSquare state.grid.squares coordinate))
        return unit
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      addMouseEventListener MouseClickEvent (\e -> clickListener st e) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Refactored rendering of border to its own function

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just { color: colorPlayerOne, king: false }
                  else
                    if hasPlayerTwo
                    then Just { color: colorPlayerTwo, king: false }
                    else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers = { grid: (createGrid offset width height layers), currentPlayer: 1 }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just { color: colorPlayerOne, king: false }
                  else
                    if hasPlayerTwo
                    then Just { color: colorPlayerTwo, king: false }
                    else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers = { grid: (createGrid offset width height layers), currentPlayer: 1 }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


More work on porting psc

More work on porting psc

-----------------------------------------------------------------------------
--
-- Module      :  Compiler
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- | psc frontend to the PureScript library
--
-----------------------------------------------------------------------------

module Compiler where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Tuple3
import Data.Array (concat, map)
import Data.Either

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Control.Apply
import Control.Monad.Identity
import Control.Monad.State.Class
import Control.Monad.Error.Trans
import Control.Monad.Error.Class
import Control.Monad.Cont.Trans

import Node.Args

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

foreign import data FS :: !

foreign import data Process :: !

foreign import exit
  "function exit(code) {\
  \  return function() {\
  \    process.exit(code);\
  \  };\
  \}" :: forall eff. Number -> Eff (process :: Process | eff) {}

foreign import readFile
  "function readFile(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        require('fs').readFile(filename, 'utf8', function(err, data) {\
  \          if (err) {\
  \            fail(err)();\
  \          } else {\
  \            k(data)();\
  \          }\
  \        });\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff. String -> (String -> Eff (fs :: FS | eff) {}) -> (String -> Eff (fs :: FS | eff) {}) -> Eff (fs :: FS | eff) {}

type AppMonad eff = ErrorT String (ContT {} (Eff (fs :: FS | eff)))

runAppMonad :: forall eff a. AppMonad eff a -> (Either String a -> Eff (fs :: FS | eff) {}) -> Eff (fs :: FS | eff) {}
runAppMonad app = runContT (runErrorT app)

readFileCont :: forall eff. String -> AppMonad eff String
readFileCont filename = ErrorT $ ContT $ \k -> readFile filename (k <<< Right) (k <<< Left)

preludeFilename :: String
preludeFilename = "prelude/prelude.purs"

modulesFromText :: String -> Either String [Module]
modulesFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModules tokens

readInput :: forall eff. [String] -> AppMonad eff [Module]
readInput input =
  concat <$> for input (\inputFile -> do
    text <- readFileCont inputFile
    case modulesFromText text of
      Left err -> throwError err
      Right ms -> return ms)

runCompiler :: forall eff. Options -> [String] -> Maybe String -> Maybe String -> Eff (trace :: Trace, fs :: FS, process :: Process | eff) {}
runCompiler opts input output externs = runAppMonad (readInput input) $ \modules ->
  case modules of
    Left err -> do
      trace err
      exit 1
    Right ms -> do
      case compile opts ms of
        Left err -> do
          trace err
          exit 1
        Right (Tuple3 js exts _) -> do
          case output of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path js
            Nothing -> trace js
          case externs of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path exts
            Nothing -> return {}
          exit 0

flag :: String -> String -> Args Boolean
flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm)

useStdIn :: Args Boolean
useStdIn = flag "s" "stdin"

inputFiles :: Args [String]
inputFiles = many argOnly

outputFile :: Args (Maybe String)
outputFile = opt (flagArg "o" <|> flagArg "output")

externsFile :: Args (Maybe String)
externsFile = opt (flagArg "e" <|> flagArg "externs")

noTco :: Args Boolean
noTco = flagOpt "no-tco"

performRuntimeTypeChecks :: Args Boolean
performRuntimeTypeChecks = flagOpt "runtime-type-checks"

noPrelude :: Args Boolean
noPrelude = flagOpt "no-prelude"

noMagicDo :: Args Boolean
noMagicDo = flagOpt "no-magic-do"

runMain :: Args (Maybe String)
runMain = opt (flagArg "main")

noOpts :: Args Boolean
noOpts = flagOpt "no-opts"

browserNamespace :: Args String
browserNamespace = flagArg "browser-namespace" <|> pure "PS"

dceModules :: Args [String]
dceModules = many (flagArg "m" <|> flagArg "module")

codeGenModules :: Args [String]
codeGenModules = many (flagArg "codegen")

verboseErrors :: Args Boolean
verboseErrors = flag "v" "verbose-errors"

options :: Args Options
options = mkOptions <$> noPrelude
                    <*> noTco
                    <*> performRuntimeTypeChecks
                    <*> noMagicDo
                    <*> runMain
                    <*> noOpts
                    <*> (Just <$> browserNamespace)
                    <*> dceModules
                    <*> codeGenModules
                    <*> verboseErrors

inputFilesAndPrelude :: Args [String]
inputFilesAndPrelude = combine <$> noPrelude <*> inputFiles
  where
  combine true  input = input
  combine false input = preludeFilename : input

term :: Args (Eff (trace :: Trace, fs :: FS, process :: Process) {})
term = runCompiler <$> options <*> inputFilesAndPrelude <*> outputFile <*> externsFile

main = catchException (\err -> print err) $ readArgs' term

-----------------------------------------------------------------------------
--
-- Module      :  Compiler
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- | psc frontend to the PureScript library
--
-----------------------------------------------------------------------------

module Compiler where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Either

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Control.Apply
import Control.Monad.Identity
import Control.Monad.State.Class

import Node.Args

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

foreign import data FS :: # ! -> !

foreign import data Process :: !

foreign import exit
  "function exit(code) {\
  \  return function() {\
  \    process.exit(code);\
  \  };\
  \}" :: forall eff. Number -> Eff (process :: Process | eff) {}

foreign import readFile
  "function readFile(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        require('fs').readFile(filename, 'utf8', function(err, data) {\
  \          if (err) {\
  \            fail(err);\
  \          } else {\
  \            k(data);\
  \          }\
  \        });\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff rest. String -> (String -> Eff eff {}) -> (String -> Eff eff {}) -> Eff (fs :: FS eff | rest) {}

preludeFilename :: String
preludeFilename = "prelude/prelude.purs"

modulesFromText :: String -> Either String [Module]
modulesFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModules tokens

runCompiler :: Options -> [String] -> Maybe String -> Maybe String -> Eff (trace :: Trace) {}
runCompiler _ _ _ _ = trace "Not implemented"

{-
readInput :: [String] -> Eff eff (Either ParseError [Tuple String Module])
readInput input =
  collect <$> for input $ \inputFile -> do
    text <- readFile inputFile
    let modules = modulesFromText text
    return $ (Tuple inputFile modules)
  where
  collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
  collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)

compile :: Options -> [String] -> Maybe FilePath -> Maybe FilePath -> IO ()
compile opts input output externs = do
  modules <- readInput input
  case modules of
    Left err -> do
      U.print err
      exitFailure
    Right ms -> do
      case P.compile opts (map snd ms) of
        Left err -> do
          print err
          exit 1
        Right (Tuple3 js exts _) -> do
          case output of
            Just path -> mkdirp path >> U.writeFile path js
            Nothing -> U.putStrLn js
          case externs of
            Just path -> mkdirp path >> U.writeFile path exts
            Nothing -> return {}
          exit 0

mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing true . takeDirectory
-}

flag :: String -> String -> Args Boolean
flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm)

useStdIn :: Args Boolean
useStdIn = flag "s" "stdin"

inputFiles :: Args [String]
inputFiles = many argOnly

outputFile :: Args (Maybe String)
outputFile = opt (flagArg "o" <|> flagArg "output")

externsFile :: Args (Maybe String)
externsFile = opt (flagArg "e" <|> flagArg "externs")

noTco :: Args Boolean
noTco = flagOpt "no-tco"

performRuntimeTypeChecks :: Args Boolean
performRuntimeTypeChecks = flagOpt "runtime-type-checks"

noPrelude :: Args Boolean
noPrelude = flagOpt "no-prelude"

noMagicDo :: Args Boolean
noMagicDo = flagOpt "no-magic-do"

runMain :: Args (Maybe String)
runMain = opt (flagArg "main")

noOpts :: Args Boolean
noOpts = flagOpt "no-opts"

browserNamespace :: Args String
browserNamespace = flagArg "browser-namespace" <|> pure "PS"

dceModules :: Args [String]
dceModules = many (flagArg "m" <|> flagArg "module")

codeGenModules :: Args [String]
codeGenModules = many (flagArg "codegen")

verboseErrors :: Args Boolean
verboseErrors = flag "v" "verbose-errors"

options :: Args Options
options = mkOptions <$> noPrelude
                    <*> noTco
                    <*> performRuntimeTypeChecks
                    <*> noMagicDo
                    <*> runMain
                    <*> noOpts
                    <*> (Just <$> browserNamespace)
                    <*> dceModules
                    <*> codeGenModules
                    <*> verboseErrors

inputFilesAndPrelude :: Args [String]
inputFilesAndPrelude = combine <$> (not <$> noPrelude) <*> inputFiles
  where
  combine true  input = preludeFilename : input
  combine false input = input

term :: Args (Eff (trace :: Trace) {})
term = runCompiler <$> options <*> inputFilesAndPrelude <*> outputFile <*> externsFile

main = catchException (\err -> print err) $ readArgs' term


Add ability to substitute free variables for expressions in a global environment

Necessary to add support for definitions

module Data.Expr where

import Prelude
import Data.Maybe
import Control.Alt ((<|>))
import Data.Generic

import qualified Data.Map as Map
import Data.Array.Unsafe (unsafeIndex)
import Data.String (fromCharArray)

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Data.Syntax

data Expr
  = Bound Name Int
  | Free Name
  | Bind Name Expr
  | App Expr Expr

type Environment = Map.Map Name Expr

derive instance genericExpr :: Generic Expr
instance showExpr :: Show Expr where
  show = gShow

syntaxToExpr :: Syntax -> Expr
syntaxToExpr = loop Map.empty
 where
  loop env a =
    case a of
      Var n ->
        maybe (Free n) (Bound n) (Map.lookup n env)
      Lambda n b ->
        let env' = Map.insert n 0 (map (+1) env)
        in Bind n (loop env' b)
      Apply f a ->
        App (loop env f) (loop env a)

exprToSyntax :: Expr -> Syntax
exprToSyntax e =
  case e of
    Bound n _ -> Var n
    Free n    -> Var n
    Bind n e  -> Lambda n (exprToSyntax e)
    App f a   -> Apply (exprToSyntax f) (exprToSyntax a)

instance prettyPrintExpr :: PrettyPrint Expr where
  prettyPrint = walk false
   where
    walk inApp e =
      case e of
        Bound n i -> show i
        Free n    -> n
        Bind _ b  -> parensIf inApp ("λ. " <> walk false b)
        App f a   -> walk true f <> " " <> walk true a

subscriptByIndex :: Array Char
subscriptByIndex = ['₀', '₁', '₂', '₃', '₄', '₅', '₆', '₇', '₈', '₉']

subscript :: Int -> String
subscript = digits >>> map (unsafeIndex subscriptByIndex) >>> fromCharArray

digits :: Int -> Array Int
digits n
  | n < 10    = [n]
  | otherwise = digits (n `div` 10) <> [n `mod` 10]

step :: Environment -> Expr -> Maybe Expr
step env e =
  case e of
    App (Bind n e) m ->
      return (substitute m 0 e)
    App f a ->
      (App <$> step env f <*> pure a) <|> (App <$> pure f <*> step env a)
    Bind n e ->
      Bind n <$> step env e
    Free n ->
      Map.lookup n env
    Bound n i ->
      Nothing

substitute :: Expr -> Int -> Expr -> Expr
substitute v = walk
 where
  walk index e =
    case e of
      Bound n i
        | i == index -> v
        | otherwise  -> Bound n i
      Free n -> Free n
      Bind n b -> Bind n (walk (index + 1) b)
      App f a -> App (walk index f) (walk index a)

module Data.Expr where

import Prelude
import Data.Maybe
import Control.Alt ((<|>))
import Data.Generic

import qualified Data.Map as Map
import Data.Array.Unsafe (unsafeIndex)
import Data.String (fromCharArray)

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Data.Syntax

data Expr
  = Bound Name Int
  | Free Name
  | Bind Name Expr
  | App Expr Expr

derive instance genericExpr :: Generic Expr
instance showExpr :: Show Expr where
  show = gShow

syntaxToExpr :: Syntax -> Expr
syntaxToExpr = loop Map.empty
 where
  loop env a =
    case a of
      Var n ->
        maybe (Free n) (Bound n) (Map.lookup n env)
      Lambda n b ->
        let env' = Map.insert n 0 (map (+1) env)
        in Bind n (loop env' b)
      Apply f a ->
        App (loop env f) (loop env a)

exprToSyntax :: Expr -> Syntax
exprToSyntax e =
  case e of
    Bound n _ -> Var n
    Free n    -> Var n
    Bind n e  -> Lambda n (exprToSyntax e)
    App f a   -> Apply (exprToSyntax f) (exprToSyntax a)

instance prettyPrintExpr :: PrettyPrint Expr where
  prettyPrint = walk false
   where
    walk inApp e =
      case e of
        Bound n i -> show i
        Free n    -> n
        Bind _ b  -> parensIf inApp ("λ. " <> walk false b)
        App f a   -> walk true f <> " " <> walk true a

subscriptByIndex :: Array Char
subscriptByIndex = ['₀', '₁', '₂', '₃', '₄', '₅', '₆', '₇', '₈', '₉']

subscript :: Int -> String
subscript = digits >>> map (unsafeIndex subscriptByIndex) >>> fromCharArray

digits :: Int -> Array Int
digits n
  | n < 10    = [n]
  | otherwise = digits (n `div` 10) <> [n `mod` 10]

step :: Expr -> Maybe Expr
step e =
  case e of
    App (Bind n e) m -> return (substitute m 0 e)
    App f a ->
      (App <$> step f <*> pure a)
      <|> (App <$> pure f <*> step a)
    Bind n e -> do
      e' <- step e
      return (Bind n e')
    Free n -> Nothing
    Bound n i -> Nothing

watch :: forall eff. Int -> Expr -> Eff (console :: CONSOLE | eff) Unit
watch 0 e = log (prettyPrint (exprToSyntax e))
watch n e = do
  log (prettyPrint (exprToSyntax e))
  maybe (return unit) (watch (n - 1)) (step e)

substitute :: Expr -> Int -> Expr -> Expr
substitute v = walk
 where
  walk index e =
    case e of
      Bound n i
        | i == index -> v
        | otherwise  -> Bound n i
      Free n -> Free n
      Bind n b -> Bind n (walk (index + 1) b)
      App f a -> App (walk index f) (walk index a)


Use Only alias

Use Only alias

module Test.Spec (
  Name(..),
  Only(..),
  Result(..),
  Group(..),
  Spec(..),
  SpecEffects,
  describe,
  describeOnly,
  pending,
  it,
  itOnly,
  collect,
  countTests
  ) where

import Prelude

import Control.Monad.Aff           (Aff())
import Control.Monad.Eff.Exception (Error())
import Control.Monad.State         (State(), modify, execState, runState)
import Control.Monad.State         as State
import Data.Traversable            (for, for_)
import Data.Tuple                  (snd)

import Node.Process               (PROCESS)
import Control.Monad.Aff.AVar     (AVAR)
import Control.Monad.Eff.Console  (CONSOLE)
import Control.Monad.Eff.Timer    (TIMER)

type Name = String
type Only = Boolean

data Group t
  = Describe Only Name (Array (Group t))
  | It Only Name t
  | Pending Name

data Result
  = Success
  | Failure Error

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  eq Success Success = true
  eq (Failure _) (Failure _) = true
  eq _ _ = false

instance showGroup :: Show t => Show (Group t) where
  show (Describe only name groups) = "Describe " <> show only <> " " <> show name <> " " <> show groups
  show (It only name test) = "It " <> show only <> " " <> show name <> " " <> show test
  show (Pending name) = "Describe " <> show name

instance eqGroup :: Eq t => Eq (Group t) where
  eq (Describe o1 n1 g1) (Describe o2 n2 g2) = o1 == o2 && n1 == n2 && g1 == g2
  eq (It o1 n1 t1)       (It o2 n2 t2)       = o1 == o2 && n1 == n2 && t1 == t2
  eq (Pending n1)        (Pending n2)        = n1 == n2
  eq _                   _                   = false

-- Specifications with unevaluated tests.
type SpecEffects e =  ( process :: PROCESS
                      , console :: CONSOLE
                      , timer   :: TIMER
                      , avar    :: AVAR
                      | e)
type Spec  eff t = State (Array (Group (Aff eff Unit))) t

collect :: forall r. Spec r Unit
        -> Array (Group (Aff r Unit))
collect r = snd $ runState r []

-- | Count the total number of tests in a spec
countTests :: forall r. Spec r Unit -> Int
countTests spec = execState (for (collect spec) go) 0
  where
  go (Describe _ _ xs) = for_ xs go
  go _ = State.modify (_ + 1)

---------------------
--       DSL       --
---------------------

-- | Combine a group of specs into a described hierarchy that either has the
-- |"only" modifier applied or not.
_describe :: forall r. Boolean
         -> String
         -> Spec r Unit
         -> Spec r Unit
_describe only name its =
  modify (_ <> [Describe only name (collect its)]) $> unit

-- | Combine a group of specs into a described hierarchy.
describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe = _describe false

-- | Combine a group of specs into a described hierarchy and mark it as the
-- | only group to actually be evaluated. (useful for quickly narrowing down
-- | on a set)
describeOnly :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describeOnly = _describe true

-- | Create a pending spec.
pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p <> [Pending name]

-- | Create a pending spec with a body that is ignored by
-- | the runner. It can be useful for documenting what the
-- | spec should test when non-pending.
pending' :: forall r. String
        -> Aff r Unit
        -> Spec r Unit
pending' name _ = pending name

-- | Create a spec with a description that either has the "only" modifier
-- | applied or not
_it :: forall eff. Boolean
   -> String
   -> Aff eff Unit
   -> Spec eff Unit
_it only description tests = modify (_ <> [It only description tests]) $> unit

-- | Create a spec with a description.
it :: forall eff. String
   -> Aff  eff Unit
   -> Spec  eff Unit
it = _it false

-- | Create a spec with a description and mark it as the only one to
-- | be run. (useful for quickly narrowing down on a single test)
itOnly :: forall eff. String
   -> Aff eff Unit
   -> Spec eff Unit
itOnly = _it true

module Test.Spec (
  Name(..),
  Result(..),
  Group(..),
  Spec(..),
  SpecEffects,
  describe,
  describeOnly,
  pending,
  it,
  itOnly,
  collect,
  countTests
  ) where

import Prelude

import Control.Monad.Aff           (Aff())
import Control.Monad.Eff.Exception (Error())
import Control.Monad.State         (State(), modify, execState, runState)
import Control.Monad.State         as State
import Data.Traversable            (for, for_)
import Data.Tuple                  (snd)

import Node.Process               (PROCESS)
import Control.Monad.Aff.AVar     (AVAR)
import Control.Monad.Eff.Console  (CONSOLE)
import Control.Monad.Eff.Timer    (TIMER)

type Name = String
type Only = Boolean

data Group t
  = Describe Boolean Name (Array (Group t))
  | It Boolean Name t
  | Pending Name

data Result
  = Success
  | Failure Error

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  eq Success Success = true
  eq (Failure _) (Failure _) = true
  eq _ _ = false

instance showGroup :: Show t => Show (Group t) where
  show (Describe only name groups) = "Describe " <> show only <> " " <> show name <> " " <> show groups
  show (It only name test) = "It " <> show only <> " " <> show name <> " " <> show test
  show (Pending name) = "Describe " <> show name

instance eqGroup :: Eq t => Eq (Group t) where
  eq (Describe o1 n1 g1) (Describe o2 n2 g2) = o1 == o2 && n1 == n2 && g1 == g2
  eq (It o1 n1 t1)       (It o2 n2 t2)       = o1 == o2 && n1 == n2 && t1 == t2
  eq (Pending n1)        (Pending n2)        = n1 == n2
  eq _                   _                   = false

-- Specifications with unevaluated tests.
type SpecEffects e =  ( process :: PROCESS
                      , console :: CONSOLE
                      , timer   :: TIMER
                      , avar    :: AVAR
                      | e)
type Spec  eff t = State (Array (Group (Aff eff Unit))) t

collect :: forall r. Spec r Unit
        -> Array (Group (Aff r Unit))
collect r = snd $ runState r []

-- | Count the total number of tests in a spec
countTests :: forall r. Spec r Unit -> Int
countTests spec = execState (for (collect spec) go) 0
  where
  go (Describe _ _ xs) = for_ xs go
  go _ = State.modify (_ + 1)

---------------------
--       DSL       --
---------------------

-- | Combine a group of specs into a described hierarchy that either has the
-- |"only" modifier applied or not.
_describe :: forall r. Boolean
         -> String
         -> Spec r Unit
         -> Spec r Unit
_describe only name its =
  modify (_ <> [Describe only name (collect its)]) $> unit

-- | Combine a group of specs into a described hierarchy.
describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe = _describe false

-- | Combine a group of specs into a described hierarchy and mark it as the
-- | only group to actually be evaluated. (useful for quickly narrowing down
-- | on a set)
describeOnly :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describeOnly = _describe true

-- | Create a pending spec.
pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p <> [Pending name]

-- | Create a pending spec with a body that is ignored by
-- | the runner. It can be useful for documenting what the
-- | spec should test when non-pending.
pending' :: forall r. String
        -> Aff r Unit
        -> Spec r Unit
pending' name _ = pending name

-- | Create a spec with a description that either has the "only" modifier
-- | applied or not
_it :: forall eff. Boolean
   -> String
   -> Aff eff Unit
   -> Spec eff Unit
_it only description tests = modify (_ <> [It only description tests]) $> unit

-- | Create a spec with a description.
it :: forall eff. String
   -> Aff  eff Unit
   -> Spec  eff Unit
it = _it false

-- | Create a spec with a description and mark it as the only one to
-- | be run. (useful for quickly narrowing down on a single test)
itOnly :: forall eff. String
   -> Aff eff Unit
   -> Spec eff Unit
itOnly = _it true


whenMaybe is actually for_

whenMaybe is actually for_

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Cache.Eval where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Lens ((^.), (.~))
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Quasar.Types (FilePath)
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port
import SqlSquared as Sql
import Utils.Path as PU
import Utils.SqlSquared (tableRelation, all)

eval
  ∷ ∀ m
  . MonadAsk CEM.CardEnv m
  ⇒ MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ Maybe String
  → Port.Resource
  → m Port.Out
eval mfp resource =
  Port.resourceOut <$> case mfp of
    Nothing → do
      tmp ← CEM.temporaryOutputResource
      eval' tmp resource
    Just pt →
      case PU.parseAnyPath pt of
        Just (Right fp) → eval' fp resource
        _ → CE.throwCacheError (CE.CacheInvalidFilepath pt)

eval'
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ FilePath
  → Port.Resource
  → m Port.Resource
eval' tmp resource = do
  let
    filePath = resource ^. Port._filePath
    backendPath = fromMaybe Path.rootDir $ Path.parentDir filePath
    sql =
      Sql.buildSelect
        $ all
        ∘ (Sql._relations .~ tableRelation filePath)
  outputResource ← CE.liftQ $
    QQ.fileQuery backendPath tmp sql SM.empty
  checkResult ← QFS.messageIfFileNotFound outputResource CE.CacheErrorSavingFile
  for_ (either (Just ∘ CE.CacheQuasarError) id checkResult)
    CE.throwCacheError
  when (tmp /= outputResource) $
    CE.throwCacheError (CE.CacheResourceNotModified outputResource)
  CEM.addCache outputResource
  pure (Port.Path outputResource)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Cache.Eval where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Lens ((^.), (.~))
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Quasar.Types (FilePath)
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port
import SqlSquared as Sql
import Utils.Path as PU
import Utils.SqlSquared (tableRelation, all)

eval
  ∷ ∀ m
  . MonadAsk CEM.CardEnv m
  ⇒ MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ Maybe String
  → Port.Resource
  → m Port.Out
eval mfp resource =
  Port.resourceOut <$> case mfp of
    Nothing → do
      tmp ← CEM.temporaryOutputResource
      eval' tmp resource
    Just pt →
      case PU.parseAnyPath pt of
        Just (Right fp) → eval' fp resource
        _ → CE.throwCacheError (CE.CacheInvalidFilepath pt)

eval'
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ FilePath
  → Port.Resource
  → m Port.Resource
eval' tmp resource = do
  let
    filePath = resource ^. Port._filePath
    backendPath = fromMaybe Path.rootDir $ Path.parentDir filePath
    sql =
      Sql.buildSelect
        $ all
        ∘ (Sql._relations .~ tableRelation filePath)
  outputResource ← CE.liftQ $
    QQ.fileQuery backendPath tmp sql SM.empty
  checkResult ← QFS.messageIfFileNotFound outputResource CE.CacheErrorSavingFile
  whenMaybe (either (Just ∘ CE.CacheQuasarError) id checkResult)
    CE.throwCacheError
  when (tmp /= outputResource) $
    CE.throwCacheError (CE.CacheResourceNotModified outputResource)
  CEM.addCache outputResource
  pure (Port.Path outputResource)
  where
  whenMaybe ∷ ∀ a f. Applicative f ⇒ Maybe a → (a → f Unit) → f Unit
  whenMaybe m f = maybe (pure unit) f m


Render complete error messages at front-end

module Neodoc (
  run
, run'
, runJS
, runPure
, runPure'
, parseHelpText
, parseHelpTextJS
, readSpec
, Output (..)
, module Reexports
) where

import Prelude
import Data.Array as A
import Data.Bifunctor (lmap)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Function.Uncurried
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Either (Either (..), either, fromRight)
import Data.StrMap (StrMap)
import Data.String as String
import Data.Char as Char
import Data.StrMap as StrMap
import Data.List (
  List(..), (:), many, toUnfoldable, concat, fromFoldable, catMaybes, filter
, length)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Traversable (for)
import Data.Pretty (class Pretty, pretty)
import Data.String.Regex as Regex
import Data.String.Regex (regex, Regex())
import Data.Foreign (F, Foreign)
import Data.Foreign.Class as F
import Data.Foreign.Extra as F
import Data.Foreign as F
import Data.Foldable (any, intercalate)
import Data.String.Yarn (lines, unlines)
import Control.Alt ((<|>))
import Control.Monad.Eff.Exception (Error, throwException, error, EXCEPTION)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe
import Node.Process (PROCESS)
import Node.Process as Process
import Node.FS (FS)
import Text.Wrap (dedent)
import Unsafe.Coerce (unsafeCoerce)
import Partial.Unsafe (unsafePartial)

import Neodoc.Spec
import Neodoc.Options
import Neodoc.Data.Layout
import Neodoc.Data.UsageLayout
import Neodoc.Data.LayoutConversion
import Neodoc.Data.EmptyableLayout
import Neodoc.Data.EmptyableLayout as Layout
import Neodoc.Error.Class (capture) as Error
import Neodoc.Error as Error
import Neodoc.Error (NeodocError)
import Neodoc.Scanner as Scanner
import Neodoc.SpecConversions as Spec
import Neodoc.Spec.Parser as Spec
import Neodoc.Spec.Lexer as Lexer
import Neodoc.Solve as Solver
import Neodoc.Value (Value(..))
import Neodoc.ArgParser as ArgParser
import Neodoc.ArgParser (ArgParseResult(..))
import Neodoc.Evaluate as Evaluate
import Neodoc.Data.SolvedLayout

import Neodoc.Options as Reexports

_DEVELOPER_ERROR_MESSAGE :: String
_DEVELOPER_ERROR_MESSAGE = dedent """
  This is an error with the program itself and not your fault.
  Please bring this to the program author's attention.
"""

type NeodocEff e = (
    process :: PROCESS
  , err     :: EXCEPTION
  , console :: CONSOLE
  , fs      :: FS
  | e
)

data Output
  = VersionOutput String
  | Output (StrMap Value)
  | HelpOutput String

instance prettyOutput :: Pretty Output where
  pretty (VersionOutput s) = s
  pretty (HelpOutput    s) = s
  pretty (Output        s) = show s -- TODO: make pretty

runJS
  :: ∀ eff
   . Fn2
        Foreign
        Foreign
        (Eff (NeodocEff eff) Foreign)
runJS = mkFn2 go
  where
  go fSpec fOpts = do
    spec /\ opts <- either (throwException <<< error <<< F.prettyForeignError)
                    pure
                    do
                      Tuple <$> (readSpec fSpec)
                            <*> (F.read fOpts)
    x <- _run spec opts
    pure case x of
      (Output        x) -> F.toForeign (rawValue <$> x)
      (HelpOutput    x) -> F.toForeign x
      (VersionOutput x) -> F.toForeign x

  -- | Convert a Value into a JS-native value.
  rawValue :: Value -> Unit
  rawValue (BoolValue   b) = unsafeCoerce b
  rawValue (IntValue    i) = unsafeCoerce i
  rawValue (FloatValue  x) = unsafeCoerce x
  rawValue (StringValue s) = unsafeCoerce s
  rawValue (ArrayValue xs) = unsafeCoerce $ rawValue <$> xs

readSpec
  :: Foreign
  -> F (Either (Spec UsageLayout) String)
readSpec input = do
  spec :: Either (Spec (EmptyableLayout UsageLayoutArg)) String <- do
    (Right <$> F.read input) <|>
    (Left  <$> F.read input)
  pure $ lmap Spec.fromEmptyableSpec spec

run
  :: ∀ eff
   . String
  -> NeodocOptions
  -> Eff (NeodocEff eff) Output
run help = _run (Right help)

run'
  :: ∀ eff
   . Spec UsageLayout
  -> NeodocOptions
  -> Eff (NeodocEff eff) Output
run' spec = _run (Left spec)

_run
  :: ∀ eff
   . Either (Spec UsageLayout) String
  -> NeodocOptions
  -> Eff (NeodocEff eff) Output
_run input (NeodocOptions opts) = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  let
    runNeodocError' :: ∀ a. Either _ a -> Eff _ a
    runNeodocError' = runNeodocError Nothing Nothing Nothing

  -- 1. obtain a spec, either by using the provided spec or by parsing a fresh
  --    one.
  inputSpec@(Spec { program, helpText, shortHelp }) <- runNeodocError' do
    either pure parseHelpText input

  -- 2. solve the spec
  spec@(Spec { descriptions }) <- runNeodocError' do
    let fromJSCallback
          :: ∀ a
           . (Pretty a)
          => (Spec a -> Eff _ (Spec a))
          -> (Spec a -> Either _ (Spec a))
        fromJSCallback cb = \spec ->
          let result = unsafePerformEff (cb spec)
           in Right result
    Error.capture do
      Solver.solve'
        opts
        (fromFoldable $ either (fromJSCallback <$> _) id opts.transforms.presolve)
        (fromFoldable $ either (fromJSCallback <$> _) id opts.transforms.postsolve)
        inputSpec

  let
    runNeodocError' :: ∀ a. Either _ a -> Eff _ a
    runNeodocError' = runNeodocError  (Just program)
                                      (Just opts.helpFlags)
                                      (Just shortHelp)

  -- 3. run the arg parser agains the spec and user input
  output <- runNeodocError' do
    ArgParseResult mBranch vs <- do
      Error.capture do
        ArgParser.run spec opts env argv
    pure $ Evaluate.reduce env descriptions mBranch vs

  if output `has` opts.helpFlags then
    let helpText' = trimHelp helpText
     in if opts.dontExit
          then pure (HelpOutput helpText')
          else Console.log helpText' *> Process.exit 0
    else
      if output `has` opts.versionFlags then do
        mVer <- maybe readPkgVersion (pure <<< pure) opts.version
        case mVer of
          Just ver ->
            if opts.dontExit
                then pure (VersionOutput ver)
                else Console.log ver *> Process.exit 0
          Nothing -> runNeodocError' $ Left Error.VersionMissingError
    else pure (Output output)

  where

  runNeodocError
    :: ∀ eff a
     . Maybe String         -- the program name, if available
    -> Maybe (Array String) -- the flags that trigger --help
    -> Maybe String         -- the shortened usage text
    -> Either NeodocError a
    -> Eff (NeodocEff eff) a
  runNeodocError mProg mHelpFlags mShortHelp x = case x of
    Left err ->
      let msg = renderNeodocError mProg mHelpFlags mShortHelp err
       in if opts.dontExit
            then throwException $ jsError msg {}
            else
              let msg' = if Error.isDeveloperError err
                            then msg <> "\n" <> _DEVELOPER_ERROR_MESSAGE
                            else msg
              in Console.error msg' *> Process.exit 1
    Right x -> pure x

  readPkgVersion = readPkgVersionImpl Just Nothing

runPure
  :: String
  -> NeodocOptions
  -> Maybe String
  -> Either NeodocError Output
runPure help = _runPure (Right help)

runPure'
  :: Spec UsageLayout
  -> NeodocOptions
  -> Maybe String
  -> Either NeodocError Output
runPure' spec = _runPure (Left spec)

_runPure
  :: Either (Spec UsageLayout) String
  -> NeodocOptions
  -> Maybe String
  -> Either NeodocError Output
_runPure input (NeodocOptions opts) mVer = do
  let argv = fromMaybe [] opts.argv
      env  = fromMaybe StrMap.empty opts.env

  -- 1. obtain a spec, either by using the provided spec or by parsing a fresh
  --    one.
  inputSpec@(Spec { program, helpText }) <- do
    either pure parseHelpText input

  -- 2. solve the spec
  spec@(Spec { descriptions }) <- do
    Error.capture do
      Solver.solve opts inputSpec

  -- 3. run the arg parser agains the spec and user input
  ArgParseResult mBranch vs <- do
    Error.capture do
      ArgParser.run spec opts env argv

  let output = Evaluate.reduce env descriptions mBranch vs

  if output `has` opts.helpFlags
    then pure (HelpOutput (trimHelp helpText))
    else
      if output `has` opts.versionFlags then do
        case mVer of
          Just ver -> pure (VersionOutput ver)
          Nothing ->  Left Error.VersionMissingError
      else pure (Output output)

parseHelpTextJS
  :: ∀ eff
   . Fn1
        String
        (Eff (NeodocEff eff) Foreign)
parseHelpTextJS = mkFn1 go
  where
  go help =
    case parseHelpText help of
      Left e ->
        let msg = renderNeodocError Nothing Nothing Nothing e
         in throwException $ jsError msg {}
      Right spec ->
        pure $ F.write $ Spec.toEmptyableSpec spec

parseHelpText
  :: String
  -> Either NeodocError (Spec UsageLayout)
parseHelpText help = do
  -- scan the input text
  { originalUsage, usage, options } <- Error.capture do
    Scanner.scan $ dedent help

  -- lex/parse the usage section
  { program, layouts } <- do
    toks <- Error.capture $ Lexer.lexUsage usage
    Error.capture $ Spec.parseUsage toks

  -- lex/parse the description section(s)
  descriptions <- concat <$> for options \description -> do
    toks <- Error.capture $ Lexer.lexDescs description
    Error.capture $ Spec.parseDescription toks

  pure $ Spec { program
              , layouts
              , descriptions
              , helpText: help
              , shortHelp: originalUsage
              }

renderNeodocError
  :: Maybe String         -- the program name, if available
  -> Maybe (Array String) -- the flags that trigger --help
  -> Maybe String         -- the shortened usage text
  -> NeodocError          -- the error that occured
  -> String
renderNeodocError (Just prog) mHelpFlags mShortHelp (Error.ArgParserError msg) =
  -- de-capitalize the error message after the colon
  let
    title =
      case String.uncons msg of
        Nothing -> msg
        Just { head, tail } ->
          let msg' = String.singleton (Char.toLower head) <> tail
           in prog <> ": " <> msg'
    usage = renderShortHelp mShortHelp
    help = renderHelpFlags prog mHelpFlags
   in title
        <> (if String.length title > 0 then "\n" else "")
        <> usage
        <> (if String.length usage > 0 then "\n" else "")
        <> help
  where
  renderShortHelp (Just help) =
    dedent $ unlines $ ("  " <> _) <$> lines (dedent help)
  renderShortHelp _ = ""
  renderHelpFlags prog (Just flags) | A.length flags > 0 =
    "See " <> prog <> " " <> (intercalate "/" flags)
      <> " for more information"
  renderHelpFlags _ _ = ""
renderNeodocError _ _ _ e = pretty e

has x = any \s ->
  maybe false (case _ of
                IntValue  0     -> false
                BoolValue false -> false
                ArrayValue []   -> false
                _               -> true
                ) (StrMap.lookup s x)

trimHelp = Regex.replace (regex' "(^\\s*(\r\n|\n|\r))|((\r\n|\n|\r)\\s*$)" "g") ""
  where regex' a b = unsafePartial $ fromRight $ regex a (Regex.parseFlags b)

foreign import jsError :: ∀ a. String -> a -> Error
foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)

module Neodoc (
  run
, run'
, runJS
, runPure
, runPure'
, parseHelpText
, parseHelpTextJS
, readSpec
, Output (..)
, module Reexports
) where

import Prelude
import Data.Array as A
import Data.Bifunctor (lmap)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Function.Uncurried
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Either (Either (..), either, fromRight)
import Data.StrMap (StrMap)
import Data.String as String
import Data.Char as Char
import Data.StrMap as StrMap
import Data.List (
  List(..), (:), many, toUnfoldable, concat, fromFoldable, catMaybes, filter
, length)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Traversable (for)
import Data.Pretty (class Pretty, pretty)
import Data.String.Regex as Regex
import Data.String.Regex (regex, Regex())
import Data.Foreign (F, Foreign)
import Data.Foreign.Class as F
import Data.Foreign.Extra as F
import Data.Foreign as F
import Data.Foldable (any, intercalate)
import Data.String.Yarn (lines, unlines)
import Control.Alt ((<|>))
import Control.Monad.Eff.Exception (Error, throwException, error, EXCEPTION)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe
import Node.Process (PROCESS)
import Node.Process as Process
import Node.FS (FS)
import Text.Wrap (dedent)
import Unsafe.Coerce (unsafeCoerce)
import Partial.Unsafe (unsafePartial)

import Neodoc.Spec
import Neodoc.Options
import Neodoc.Data.Layout
import Neodoc.Data.UsageLayout
import Neodoc.Data.LayoutConversion
import Neodoc.Data.EmptyableLayout
import Neodoc.Data.EmptyableLayout as Layout
import Neodoc.Error.Class (capture) as Error
import Neodoc.Error as Error
import Neodoc.Error (NeodocError)
import Neodoc.Scanner as Scanner
import Neodoc.SpecConversions as Spec
import Neodoc.Spec.Parser as Spec
import Neodoc.Spec.Lexer as Lexer
import Neodoc.Solve as Solver
import Neodoc.Value (Value(..))
import Neodoc.ArgParser as ArgParser
import Neodoc.ArgParser (ArgParseResult(..))
import Neodoc.Evaluate as Evaluate
import Neodoc.Data.SolvedLayout

import Neodoc.Options as Reexports

_DEVELOPER_ERROR_MESSAGE :: String
_DEVELOPER_ERROR_MESSAGE = dedent """
  This is an error with the program itself and not your fault.
  Please bring this to the program author's attention.
"""

type NeodocEff e = (
    process :: PROCESS
  , err     :: EXCEPTION
  , console :: CONSOLE
  , fs      :: FS
  | e
)

data Output
  = VersionOutput String
  | Output (StrMap Value)
  | HelpOutput String

instance prettyOutput :: Pretty Output where
  pretty (VersionOutput s) = s
  pretty (HelpOutput    s) = s
  pretty (Output        s) = show s -- TODO: make pretty

runJS
  :: ∀ eff
   . Fn2
        Foreign
        Foreign
        (Eff (NeodocEff eff) Foreign)
runJS = mkFn2 go
  where
  go fSpec fOpts = do
    spec /\ opts <- either (throwException <<< error <<< F.prettyForeignError)
                    pure
                    do
                      Tuple <$> (readSpec fSpec)
                            <*> (F.read fOpts)
    x <- _run spec opts
    pure case x of
      (Output        x) -> F.toForeign (rawValue <$> x)
      (HelpOutput    x) -> F.toForeign x
      (VersionOutput x) -> F.toForeign x

  -- | Convert a Value into a JS-native value.
  rawValue :: Value -> Unit
  rawValue (BoolValue   b) = unsafeCoerce b
  rawValue (IntValue    i) = unsafeCoerce i
  rawValue (FloatValue  x) = unsafeCoerce x
  rawValue (StringValue s) = unsafeCoerce s
  rawValue (ArrayValue xs) = unsafeCoerce $ rawValue <$> xs

readSpec
  :: Foreign
  -> F (Either (Spec UsageLayout) String)
readSpec input = do
  spec :: Either (Spec (EmptyableLayout UsageLayoutArg)) String <- do
    (Right <$> F.read input) <|>
    (Left  <$> F.read input)
  pure $ lmap Spec.fromEmptyableSpec spec

run
  :: ∀ eff
   . String
  -> NeodocOptions
  -> Eff (NeodocEff eff) Output
run help = _run (Right help)

run'
  :: ∀ eff
   . Spec UsageLayout
  -> NeodocOptions
  -> Eff (NeodocEff eff) Output
run' spec = _run (Left spec)

_run
  :: ∀ eff
   . Either (Spec UsageLayout) String
  -> NeodocOptions
  -> Eff (NeodocEff eff) Output
_run input (NeodocOptions opts) = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  -- 1. obtain a spec, either by using the provided spec or by parsing a fresh
  --    one.
  inputSpec@(Spec { program, helpText }) <- runNeodocError Nothing do
    either pure parseHelpText input

  -- 2. solve the spec
  spec@(Spec { descriptions }) <- runNeodocError Nothing do
    let fromJSCallback
          :: ∀ a
           . (Pretty a)
          => (Spec a -> Eff _ (Spec a))
          -> (Spec a -> Either _ (Spec a))
        fromJSCallback cb = \spec ->
          let result = unsafePerformEff (cb spec)
           in Right result
    Error.capture do
      Solver.solve'
        opts
        (fromFoldable $ either (fromJSCallback <$> _) id opts.transforms.presolve)
        (fromFoldable $ either (fromJSCallback <$> _) id opts.transforms.postsolve)
        inputSpec

  -- 3. run the arg parser agains the spec and user input
  output <- runNeodocError (Just program) do
    ArgParseResult mBranch vs <- do
      Error.capture do
        ArgParser.run spec opts env argv
    pure $ Evaluate.reduce env descriptions mBranch vs

  if output `has` opts.helpFlags then
    let helpText' = trimHelp helpText
     in if opts.dontExit
          then pure (HelpOutput helpText')
          else Console.log helpText' *> Process.exit 0
    else
      if output `has` opts.versionFlags then do
        mVer <- maybe readPkgVersion (pure <<< pure) opts.version
        case mVer of
          Just ver ->
            if opts.dontExit
                then pure (VersionOutput ver)
                else Console.log ver *> Process.exit 0
          Nothing -> runNeodocError (Just program) (Left Error.VersionMissingError)
    else pure (Output output)

  where

  runNeodocError
    :: ∀ eff a
     . Maybe String
    -> Either NeodocError a
    -> Eff (NeodocEff eff) a
  runNeodocError mProg x = case x of
    Left err ->
      let msg = renderNeodocError mProg err
       in if opts.dontExit
            then throwException $ jsError msg {}
            else
              let msg' = if Error.isDeveloperError err
                            then msg <> "\n" <> _DEVELOPER_ERROR_MESSAGE
                            else msg
              in Console.error msg' *> Process.exit 1
    Right x -> pure x
  readPkgVersion = readPkgVersionImpl Just Nothing

runPure
  :: String
  -> NeodocOptions
  -> Maybe String
  -> Either NeodocError Output
runPure help = _runPure (Right help)

runPure'
  :: Spec UsageLayout
  -> NeodocOptions
  -> Maybe String
  -> Either NeodocError Output
runPure' spec = _runPure (Left spec)

_runPure
  :: Either (Spec UsageLayout) String
  -> NeodocOptions
  -> Maybe String
  -> Either NeodocError Output
_runPure input (NeodocOptions opts) mVer = do
  let argv = fromMaybe [] opts.argv
      env  = fromMaybe StrMap.empty opts.env

  -- 1. obtain a spec, either by using the provided spec or by parsing a fresh
  --    one.
  inputSpec@(Spec { program, helpText }) <- do
    either pure parseHelpText input

  -- 2. solve the spec
  spec@(Spec { descriptions }) <- do
    Error.capture do
      Solver.solve opts inputSpec

  -- 3. run the arg parser agains the spec and user input
  ArgParseResult mBranch vs <- do
    Error.capture do
      ArgParser.run spec opts env argv

  let output = Evaluate.reduce env descriptions mBranch vs

  if output `has` opts.helpFlags
    then pure (HelpOutput (trimHelp helpText))
    else
      if output `has` opts.versionFlags then do
        case mVer of
          Just ver -> pure (VersionOutput ver)
          Nothing ->  Left Error.VersionMissingError
      else pure (Output output)

parseHelpTextJS
  :: ∀ eff
   . Fn1
        String
        (Eff (NeodocEff eff) Foreign)
parseHelpTextJS = mkFn1 go
  where
  go help =
    case parseHelpText help of
      Left e ->
        let msg = renderNeodocError Nothing e
         in throwException $ jsError msg {}
      Right spec ->
        pure $ F.write $ Spec.toEmptyableSpec spec

parseHelpText
  :: String
  -> Either NeodocError (Spec UsageLayout)
parseHelpText help = do
  -- scan the input text
  { originalUsage, usage, options } <- Error.capture do
    Scanner.scan $ dedent help

  -- lex/parse the usage section
  { program, layouts } <- do
    toks <- Error.capture $ Lexer.lexUsage usage
    Error.capture $ Spec.parseUsage toks

  -- lex/parse the description section(s)
  descriptions <- concat <$> for options \description -> do
    toks <- Error.capture $ Lexer.lexDescs description
    Error.capture $ Spec.parseDescription toks

  pure $ Spec { program
              , layouts
              , descriptions
              , helpText: help
              , shortHelp: originalUsage
              }

renderNeodocError :: Maybe String -> NeodocError -> String
renderNeodocError (Just prog) (Error.ArgParserError msg) =
  -- de-capitalize the error message after the colon
  case String.uncons msg of
        Nothing -> msg
        Just { head, tail } ->
          let msg' = String.singleton (Char.toLower head) <> tail
          in prog <> ": " <> msg'
renderNeodocError _ e = pretty e

-- Format the user-facing help text, as printed to the console upon
-- error.
formatHelpText :: String -> Array String -> String -> String -> String
formatHelpText program helpFlags shortHelp errmsg = errmsg
  <> "\n"
  <> (dedent $ unlines $ ("  " <> _) <$> lines (dedent shortHelp))
  <> if A.length helpFlags == 0
      then ""
      else "\n" <> "See "
                    <> program <> " " <> (intercalate "/" helpFlags)
                    <> " for more information"

has x = any \s ->
  maybe false (case _ of
                IntValue  0     -> false
                BoolValue false -> false
                ArrayValue []   -> false
                _               -> true
                ) (StrMap.lookup s x)

trimHelp = Regex.replace (regex' "(^\\s*(\r\n|\n|\r))|((\r\n|\n|\r)\\s*$)" "g") ""
  where regex' a b = unsafePartial $ fromRight $ regex a (Regex.parseFlags b)

foreign import jsError :: ∀ a. String -> a -> Error
foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)


Cleaned up router a bit

Cleaned up router a bit

module Gonimo.Client.Router where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(Right, Left))
import Data.Functor ((<$))
import Data.Maybe (fromMaybe)
import Global (decodeURIComponent)
import Gonimo.Types (Secret(Secret))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (($), (<$>))
import Pux.Router (param, router, lit, int, end)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece)
import Debug.Trace (trace)
import Data.Maybe (Maybe(..))
import Data.Array (index)
import Data.Either (fromRight, either)
import Partial.Unsafe (unsafePartial)

import Data.String.Regex as R

data Route = Home | AcceptInvitation Secret

render (AcceptInvitation secret) = "acceptInvitation=" <> gDefaultEncodeURLPiece secret
render Home = ""

-- Use simple plain old regex for matching route - pux routing does not work reliably!
match :: String -> Route
-- match' url =trace ("Routing: " <> url) $ \_ -> (fromMaybe (DecodingFailedP $ "No such route: " <> url) $ router url $
--        AcceptInvitationP <$> (lit "index.html" *> param "acceptInvitation") <* end
--    <|> HomeP <$ lit "index.html" <* end
-- )
match url = let
    matcher = unsafePartial $ fromRight $ R.regex ".*acceptInvitation=([^&]*)" R.noFlags
    matched = R.match matcher url
    decode :: String -> Either String Secret
    decode = Aeson.decodeJson <=< (jsonParser <<< decodeURIComponent)
    decodeJust :: String -> Maybe Secret
    decodeJust = either (const Nothing) Just <<< decode
  in
     fromMaybe Home $ do
       arr <- matched
       element <- index arr 1
       decoded <- decodeJust =<< element
       pure $ AcceptInvitation decoded

module Gonimo.Client.Router where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(Right, Left))
import Data.Functor ((<$))
import Data.Maybe (fromMaybe)
import Global (decodeURIComponent)
import Gonimo.Types (Secret(Secret))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (($), (<$>))
import Pux.Router (param, router, lit, int, end)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece)
import Debug.Trace (trace)
import Data.Maybe (Maybe(..))
import Data.Array (index)
import Data.Either (fromRight)
import Partial.Unsafe (unsafePartial)

import Data.String.Regex as R

data Route = Home | AcceptInvitation Secret | DecodingFailed String

data RouteP = HomeP | AcceptInvitationP String | DecodingFailedP String

render (AcceptInvitation secret) = "acceptInvitation=" <> gDefaultEncodeURLPiece secret
render Home = ""

match' :: String -> RouteP
-- match' url =trace ("Routing: " <> url) $ \_ -> (fromMaybe (DecodingFailedP $ "No such route: " <> url) $ router url $
--        AcceptInvitationP <$> (lit "index.html" *> param "acceptInvitation") <* end
--    <|> HomeP <$ lit "index.html" <* end
-- )
match' url = let
    matcher = unsafePartial $ fromRight $ R.regex ".*acceptInvitation=([^&]*)" R.noFlags
    matched = R.match matcher url
  in
     case matched of
       Nothing -> HomeP
       Just arr -> case index arr 1 of
         Nothing -> HomeP
         (Just Nothing) -> HomeP
         (Just (Just val)) -> AcceptInvitationP val

match :: String -> Route
match url = let r' = match' url
            in case r' of
              HomeP -> trace ("Routing: " <> url <> ", to Home") $ \_ -> Home
              DecodingFailedP err -> trace ("Routing:" <> url <> ", to DecodingFailed") $ \_ -> DecodingFailed err
              AcceptInvitationP str -> trace ("Routing:" <> url <> ", to AcceptInvitationP, match: " <> str) $ \_ ->
                let eVal = Aeson.decodeJson =<< (jsonParser <<< decodeURIComponent) str
                in case eVal of
                  Left err  -> DecodingFailed err
                  Right val -> AcceptInvitation val