Update `mapAccum` docs (and implementation!) (#32)

Previously, the `mapAccum` arguments were not in the order one might expect (i.e. the same as other fold-style functions: `function accumulator foldable`). This has been corrected. Furthermore, the documentation contained a formatting error, which has been fixed.

module FRP.Event.Class
  ( class IsEvent
  , fold
  , folded
  , count
  , mapAccum
  , withLast
  , sampleOn
  , sampleOn_
  , keepLatest
  , fix
  , gate
  , gateBy
  , module Data.Filterable
  ) where

import Prelude

import Control.Alternative (class Alternative, (<|>))
import Data.Filterable (class Filterable, cleared, filterMap)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), snd)

-- | Functions which an `Event` type should implement, so that
-- | `Behavior`s can be defined in terms of any such event type:
-- |
-- | - `fold`: combines incoming values using the specified function,
-- | starting with the specific initial value.
-- | - `keepLatest` flattens a nested event, reporting values only from the
-- | most recent inner event.
-- | - `sampleOn`: samples an event at the times when a second event fires.
-- | - `fix`: compute a fixed point, by feeding output events back in as
-- | inputs.
class (Alternative event, Filterable event) <= IsEvent event where
  fold :: forall a b. (a -> b -> b) -> event a -> b -> event b
  keepLatest :: forall a. event (event a) -> event a
  sampleOn :: forall a b. event a -> event (a -> b) -> event b
  fix :: forall i o. (event i -> { input :: event i, output :: event o }) -> event o

-- | Count the number of events received.
count :: forall event a. IsEvent event => event a -> event Int
count s = fold (\_ n -> n + 1) s 0

-- | Combine subsequent events using a `Monoid`.
folded :: forall event a. IsEvent event => Monoid a => event a -> event a
folded s = fold append s mempty

-- | Compute differences between successive event values.
withLast :: forall event a. IsEvent event => event a -> event { now :: a, last :: Maybe a }
withLast e = filterMap identity (fold step e Nothing) where
  step a Nothing           = Just { now: a, last: Nothing }
  step a (Just { now: b }) = Just { now: a, last: Just b }

-- | Map over an event with an accumulator.
-- |
-- | For example, to keep the index of the current event:
-- |
-- | ```purescript
-- | mapAccum (\x i -> Tuple (i + 1) (Tuple x i)) 0
-- | ```
mapAccum :: forall event a b c. IsEvent event => (a -> b -> Tuple b c) -> b -> event a -> event c
mapAccum f acc xs = filterMap snd
  $ fold (\a (Tuple b _) -> pure <$> f a b) xs
  $ Tuple acc Nothing

-- | Create an `Event` which samples the latest values from the first event
-- | at the times when the second event fires, ignoring the values produced by
-- | the second event.
sampleOn_ :: forall event a b. IsEvent event => event a -> event b -> event a
sampleOn_ a b = sampleOn a (b $> identity)

-- | Sample the events that are fired while a boolean event is true. Note that,
-- | until the boolean event fires, it will be assumed to be `false`, and events
-- | will be blocked.
gate :: forall a event. IsEvent event => event Boolean -> event a -> event a
gate = gateBy (\x _ -> fromMaybe false x)

-- | Generalised form of `gateBy`, allowing for any predicate between the two
-- | events. Until a value from the first event is received, `Nothing` will be
-- | passed to the predicate.
gateBy
  :: forall a b event
   . IsEvent event
  => (Maybe a -> b -> Boolean)
  -> event a
  -> event b
  -> event b
gateBy f sampled
   = cleared
 <<< sampleOn (pure Nothing <|> (Just <$> sampled))
 <<< map \x p -> if f p x then Just x else Nothing

module FRP.Event.Class
  ( class IsEvent
  , fold
  , folded
  , count
  , mapAccum
  , withLast
  , sampleOn
  , sampleOn_
  , keepLatest
  , fix
  , gate
  , gateBy
  , module Data.Filterable
  ) where

import Prelude

import Control.Alternative (class Alternative, (<|>))
import Data.Filterable (class Filterable, cleared, filterMap)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), snd)

-- | Functions which an `Event` type should implement, so that
-- | `Behavior`s can be defined in terms of any such event type:
-- |
-- | - `fold`: combines incoming values using the specified function,
-- | starting with the specific initial value.
-- | - `keepLatest` flattens a nested event, reporting values only from the
-- | most recent inner event.
-- | - `sampleOn`: samples an event at the times when a second event fires.
-- | - `fix`: compute a fixed point, by feeding output events back in as
-- | inputs.
class (Alternative event, Filterable event) <= IsEvent event where
  fold :: forall a b. (a -> b -> b) -> event a -> b -> event b
  keepLatest :: forall a. event (event a) -> event a
  sampleOn :: forall a b. event a -> event (a -> b) -> event b
  fix :: forall i o. (event i -> { input :: event i, output :: event o }) -> event o

-- | Count the number of events received.
count :: forall event a. IsEvent event => event a -> event Int
count s = fold (\_ n -> n + 1) s 0

-- | Combine subsequent events using a `Monoid`.
folded :: forall event a. IsEvent event => Monoid a => event a -> event a
folded s = fold append s mempty

-- | Compute differences between successive event values.
withLast :: forall event a. IsEvent event => event a -> event { now :: a, last :: Maybe a }
withLast e = filterMap identity (fold step e Nothing) where
  step a Nothing           = Just { now: a, last: Nothing }
  step a (Just { now: b }) = Just { now: a, last: Just b }

-- | Map over an event with an accumulator.
-- |
-- | For example, to keep the index of the current event:
-- |
-- | ```purescript
-- | mapAccum (\x i -> Tuple (i + 1) (Tuple x i)) 0`.
-- | ```
mapAccum :: forall event a b c. IsEvent event => (a -> b -> Tuple b c) -> event a -> b -> event c
mapAccum f xs acc = filterMap snd
  $ fold (\a (Tuple b _) -> pure <$> f a b) xs
  $ Tuple acc Nothing

-- | Create an `Event` which samples the latest values from the first event
-- | at the times when the second event fires, ignoring the values produced by
-- | the second event.
sampleOn_ :: forall event a b. IsEvent event => event a -> event b -> event a
sampleOn_ a b = sampleOn a (b $> identity)

-- | Sample the events that are fired while a boolean event is true. Note that,
-- | until the boolean event fires, it will be assumed to be `false`, and events
-- | will be blocked.
gate :: forall a event. IsEvent event => event Boolean -> event a -> event a
gate = gateBy (\x _ -> fromMaybe false x)

-- | Generalised form of `gateBy`, allowing for any predicate between the two
-- | events. Until a value from the first event is received, `Nothing` will be
-- | passed to the predicate.
gateBy
  :: forall a b event
   . IsEvent event
  => (Maybe a -> b -> Boolean)
  -> event a
  -> event b
  -> event b
gateBy f sampled
   = cleared
 <<< sampleOn (pure Nothing <|> (Just <$> sampled))
 <<< map \x p -> if f p x then Just x else Nothing


instance Applicative EArray

instance Applicative EArray

module KanColle.Expedition.New.EArray
  ( EArray()
  , mkEA
  , indEA
  , unEA
  ) where

import Prelude
import Partial.Unsafe
import Partial
import Data.Array as A
import Data.Array.Partial as AP
import Data.Unfoldable

-- array wrappered for all 40 expeditions
newtype EArray a = EA (Array a)

mkEA :: forall a. Array a -> EArray a
mkEA xs
    | A.length xs == 40 = EA xs
    | otherwise = unsafePartial (crash "expecting exactly 40 elements")

indEA :: forall a. EArray a -> Int -> a
indEA (EA xs) i
    | 1 <= i && i <= 40 = unsafePartial (AP.unsafeIndex xs (i-1))
    | otherwise = unsafePartial (crash "index out of range")

unEA :: forall a. EArray a -> Array a
unEA (EA xs) = xs

-- is functor instance necessary?
instance functorEArray :: Functor EArray where
  map f (EA xs) = EA (map f xs)

pureEA :: forall a. a -> EArray a
pureEA =
    -- no need for passing through the smart constructor
    -- at the cost of being more careful about our code
    replicate 40 >>> EA

appEA :: forall a b. EArray (a -> b) -> EArray a -> EArray b
appEA (EA fs) (EA xs) = EA (A.zipWith ($) fs xs)

instance applyEArray :: Apply EArray where
  apply = appEA

instance applicativeEArray :: Applicative EArray where
  pure = pureEA

module KanColle.Expedition.New.EArray
  ( EArray()
  , mkEA
  , indEA
  , unEA
  ) where

import Prelude
import Partial.Unsafe
import Partial
import Data.Array as A
import Data.Array.Partial as AP

-- array wrappered for all 40 expeditions
newtype EArray a = EA (Array a)

mkEA :: forall a. Array a -> EArray a
mkEA xs
    | A.length xs == 40 = EA xs
    | otherwise = unsafePartial (crash "expecting exactly 40 elements")

indEA :: forall a. EArray a -> Int -> a
indEA (EA xs) i
    | 1 <= i && i <= 40 = unsafePartial (AP.unsafeIndex xs (i-1))
    | otherwise = unsafePartial (crash "index out of range")

unEA :: forall a. EArray a -> Array a
unEA (EA xs) = xs

-- is functor instance necessary?
instance functorEArray :: Functor EArray where
  map f (EA xs) = EA (map f xs)


SessionInvalid error would be shown to the user now.

Would because, subscriber currently does not deliver errors of
pong/close commands.

module Gonimo.UI.Error ( class ErrorAction
                       , resetDevice
                       , nop
                       , clearError
                       , UserError(..)
                       , handleError
                       , handleSubscriber
                       , viewError ) where

import Data.Array as Arr
import Data.Unfoldable as Unfoldable
import Gonimo.Client.Effects as Gonimo
import Gonimo.Server.Error as Server
import Pux.Html.Attributes as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import Control.Monad.IO (IO)
import Control.Monad.State.Class (modify, class MonadState)
import Data.Either (Either(Left, Right), either)
import Data.Generic (gShow)
import Data.Maybe (fromMaybe, maybe, Maybe(Just, Nothing))
import Gonimo.Client.Types (GonimoError(RegisterSessionFailed, AjaxError, UnexpectedAction))
import Gonimo.Server.Error (ServerError)
import Pux.Html (div, button, p, h1, text, Html)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (requestToString, ErrorDescription(ConnectionError), responseToString, unsafeToString, ErrorDescription(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.Subscriber.Connection (Notification(HttpRequestFailed, ParseError, WebSocketClosed, WebSocketOpened, WebSocketError))
import Servant.Subscriber.Internal (doDecode)
import Servant.Subscriber.Request (HttpRequest)
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Util (toUserType)
import Prelude hiding (div)

type State r = { userError :: UserError | r }

class ErrorAction action where
  resetDevice :: action
  clearError :: action
  nop :: action

-- | Errors which are of concern for the user and should be displayed.
data UserError = NoError
               | DeviceInvalid -- Server does not accept our device secret.
               | AlreadyFamilyMember
               | NoSuchFamily
               | FamilyNotOnline
               | NoSuchInvitation
               | InvitationAlreadyClaimed
               | ConnectionFailed
               | SessionStolen

handleError :: forall eff r m action. ( ErrorAction action, MonadState (State r) m )
               => GonimoError -> m (Array (IO action))
handleError err = case err of
  UnexpectedAction msg -> logError "An unexpected action occurred: " msg
  RegisterSessionFailed err -> handleAjaxError err
  AjaxError err -> handleAjaxError err

handleAjaxError :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                   => Affjax.AjaxError -> m (Array (IO action))
handleAjaxError (Affjax.AjaxError err) = case err.description of
  ParsingError msg -> logError "Parsing error in Ajax request: " msg
  DecodingError msg -> logError "Decoding error in Ajax request: " msg
  ConnectionError msg -> do
    modify $ setError ConnectionFailed
    logError "Ajax request failed: " msg
  UnexpectedHTTPStatus response ->
    handleEncodedServerError (requestToString err.request) (responseToString response) response.response

handleSubscriber :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                    => Notification -> m (Array (IO action))
handleSubscriber notification =
  case notification of
    WebSocketError msg           -> logError "A websocket error occurred: " msg
    WebSocketOpened              -> logError "WebSocket connection established!" ""
    WebSocketClosed msg          -> logError "The websocket connection got closed: " msg
    ParseError msg               -> logError "A parsing error occurred: " msg
    HttpRequestFailed req' resp' -> handleFailedHttpRequest req' resp'

handleFailedHttpRequest :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                           => HttpRequest -> HttpResponse -> m (Array (IO action))
handleFailedHttpRequest req' fResp@(HttpResponse resp') =
  handleEncodedServerError (gShow req') (gShow fResp) resp'.httpBody

handleEncodedServerError :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                            => String -> String -> String -> m (Array (IO action))
handleEncodedServerError req' resp' value = do
  modify updateState
  pure [ case decodingResult of
            Right _ ->  do
              Gonimo.log "Got server error!"
              Gonimo.log $ "For request: " <> req'
              Gonimo.log $ "Response was: " <> resp'
              pure nop

            Left err ->  do
              Gonimo.log $ "Decoding error while handling failed http request: " <> err
              Gonimo.log $ "For request: " <> req'
              Gonimo.log $ "Response was: " <> resp'
              pure nop
       ]
  where
    updateState state = case error of
        NoError -> state
        _       -> setError error state
    fromServer = fromMaybe NoError <<< ( fromServerError =<< _ )
    decodingResult = doDecode (toUserType fromServer) value
    error = either (const NoError) id decodingResult

viewError :: forall r action. ErrorAction action
             => State r -> Html action
viewError state = case state.userError of
  NoError -> text "No error occurred - everything is fine!"
  DeviceInvalid -> errorView (Just resetDevice) "Your account is no longer valid"
    $ div []
      [ p []
        [ text  "We are sorry, but your account is no longer known by our server." ]
      , p []
        [ text
          $ "To proceed I would create a new account for you. You will have to rejoin any "
          <> "families you were in already."
        ]
      , p [] [ text "I am sorry for any inconveniences!" ]
      ]
  AlreadyFamilyMember -> errorView (Just clearError) "You are already a member of this family!"
    $ div []
      [ p [] [ text "You cannot join a family you are already a member of."]
      , p [] [ text $ "If you want to invite another device, please send another invitation."
                    <>"The link you just used, is now invalid! (Security, you know ... )"
             ]
      ]
  ConnectionFailed -> errorView (Just clearError) "No Internet Connection?"
    $ div []
      [ p [] [ text "We cannot reach our server."]
      , p [] [ text "Please make sure that you have a working internet connection and try again."
             ]
      ]
  NoSuchFamily -> errorView (Just clearError) "Your family no longer exists!"
    $ div []
      [ p [] [ text "It probably got deleted, we are sorry about that."]
      ]
  FamilyNotOnline -> errorView (Just clearError) "Your family is not online!"
    $ div []
      [ p [] [ text "This should not happen - like ever, if it happens, this is a bug. It can also happen if you open gonimo on multiple tabs in the same browser - which currently is not prevented (also a shortcoming of the current version)."]
      ]
  InvitationAlreadyClaimed -> errorView (Just clearError) "This invitation is already claimed!"
    $ div []
      [ p [] [ text "Another device already claimed this invitation."]
      , p [] [ text $ "Only this other device is now able to accept or decline the invitation."
             ]
      , p [] [ text "Security and stuff ...." ]
      ]
  NoSuchInvitation -> errorView (Just clearError) "This invitation no longer exists!"
    $ div []
      [ p [] [ text "For security reasons, invitations are only valid once."]
      , p [] [ text $ "Please send a new invitation from a device already in the family you were about to join."
             ]
      ]
  SessionStolen -> errorView (Just clearError) "Are you online in another browser tab?"
    $ div []
      [ p [] [ text "It seems you started gonimo twice in the same browser. This is not supported." ]
      , p [] [ text $ "Please close one tab and reload the other. Pressing 'Proceed' currently fixes nothing - yeah I have to fix that! :-)"
             ]
      ]

errorView :: forall action. ErrorAction action
             => Maybe action -> String -> Html action -> Html action
errorView = errorView' "Proceed"

errorView' :: forall action. ErrorAction action
             => String -> Maybe action -> String -> Html action -> Html action
errorView' btnText action heading body =
    div [ A.className "alert alert-danger", A.role "alert" ]
    $ [ h1 [] [ text heading ]
      , body
      ]
      <> Arr.fromFoldable (map renderButton action)
  where
    renderButton :: action -> Html action
    renderButton action =
      div [ A.className "btn-group", A.role "group" ]
      [ button
        [ A.className "btn btn-danger btn-lg btn-block", E.onClick $ const action ]
        [ text btnText ]
      ]

logError :: forall action m. (ErrorAction action, Applicative m)
                 => String -> String -> m (Array (IO action))
logError prefix msg = pure [ do
                              Gonimo.log $ prefix <> msg
                              pure nop
                           ]

fromServerError :: ServerError -> Maybe UserError
fromServerError err = case err of
    Server.InvalidAuthToken         -> Just DeviceInvalid
    Server.AlreadyFamilyMember      -> Just AlreadyFamilyMember
    Server.NoSuchFamily _           -> Just NoSuchFamily
    Server.FamilyNotOnline _        -> Just FamilyNotOnline
    Server.InvitationAlreadyClaimed -> Just InvitationAlreadyClaimed
    Server.NoSuchInvitation         -> Just NoSuchInvitation
    Server.SessionInvalid           -> Just SessionStolen
    _                               -> Nothing

-- | Sets userError in state but only if it was NoError before. (Does not overwrite an existing error)
setError :: forall r. UserError -> (State r) -> (State r)
setError error state = case state.userError of
  NoError -> state { userError = error }
  _ -> state

module Gonimo.UI.Error ( class ErrorAction
                       , resetDevice
                       , nop
                       , clearError
                       , UserError(..)
                       , handleError
                       , handleSubscriber
                       , viewError ) where

import Data.Array as Arr
import Data.Unfoldable as Unfoldable
import Gonimo.Client.Effects as Gonimo
import Gonimo.Server.Error as Server
import Pux.Html.Attributes as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import Control.Monad.IO (IO)
import Control.Monad.State.Class (modify, class MonadState)
import Data.Either (Either(Left, Right), either)
import Data.Generic (gShow)
import Data.Maybe (fromMaybe, maybe, Maybe(Just, Nothing))
import Gonimo.Client.Types (GonimoError(RegisterSessionFailed, AjaxError, UnexpectedAction))
import Gonimo.Server.Error (ServerError)
import Pux.Html (div, button, p, h1, text, Html)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (requestToString, ErrorDescription(ConnectionError), responseToString, unsafeToString, ErrorDescription(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.Subscriber.Connection (Notification(HttpRequestFailed, ParseError, WebSocketClosed, WebSocketOpened, WebSocketError))
import Servant.Subscriber.Internal (doDecode)
import Servant.Subscriber.Request (HttpRequest)
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Util (toUserType)
import Prelude hiding (div)

type State r = { userError :: UserError | r }

class ErrorAction action where
  resetDevice :: action
  clearError :: action
  nop :: action

-- | Errors which are of concern for the user and should be displayed.
data UserError = NoError
               | DeviceInvalid -- Server does not accept our device secret.
               | AlreadyFamilyMember
               | NoSuchFamily
               | FamilyNotOnline
               | NoSuchInvitation
               | InvitationAlreadyClaimed
               | ConnectionFailed

handleError :: forall eff r m action. ( ErrorAction action, MonadState (State r) m )
               => GonimoError -> m (Array (IO action))
handleError err = case err of
  UnexpectedAction msg -> logError "An unexpected action occurred: " msg
  RegisterSessionFailed err -> handleAjaxError err
  AjaxError err -> handleAjaxError err

handleAjaxError :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                   => Affjax.AjaxError -> m (Array (IO action))
handleAjaxError (Affjax.AjaxError err) = case err.description of
  ParsingError msg -> logError "Parsing error in Ajax request: " msg
  DecodingError msg -> logError "Decoding error in Ajax request: " msg
  ConnectionError msg -> do
    modify $ setError ConnectionFailed
    logError "Ajax request failed: " msg
  UnexpectedHTTPStatus response ->
    handleEncodedServerError (requestToString err.request) (responseToString response) response.response

handleSubscriber :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                    => Notification -> m (Array (IO action))
handleSubscriber notification =
  case notification of
    WebSocketError msg           -> logError "A websocket error occurred: " msg
    WebSocketOpened              -> logError "WebSocket connection established!" ""
    WebSocketClosed msg          -> logError "The websocket connection got closed: " msg
    ParseError msg               -> logError "A parsing error occurred: " msg
    HttpRequestFailed req' resp' -> handleFailedHttpRequest req' resp'

handleFailedHttpRequest :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                           => HttpRequest -> HttpResponse -> m (Array (IO action))
handleFailedHttpRequest req' fResp@(HttpResponse resp') =
  handleEncodedServerError (gShow req') (gShow fResp) resp'.httpBody

handleEncodedServerError :: forall r m action. ( ErrorAction action, MonadState (State r) m )
                            => String -> String -> String -> m (Array (IO action))
handleEncodedServerError req' resp' value = do
  modify updateState
  pure [ case decodingResult of
            Right _ ->  do
              Gonimo.log "Got server error!"
              Gonimo.log $ "For request: " <> req'
              Gonimo.log $ "Response was: " <> resp'
              pure nop

            Left err ->  do
              Gonimo.log $ "Decoding error while handling failed http request: " <> err
              Gonimo.log $ "For request: " <> req'
              Gonimo.log $ "Response was: " <> resp'
              pure nop
       ]
  where
    updateState state = case error of
        NoError -> state
        _       -> setError error state
    fromServer = fromMaybe NoError <<< ( fromServerError =<< _ )
    decodingResult = doDecode (toUserType fromServer) value
    error = either (const NoError) id decodingResult

viewError :: forall r action. ErrorAction action
             => State r -> Html action
viewError state = case state.userError of
  NoError -> text "No error occurred - everything is fine!"
  DeviceInvalid -> errorView (Just resetDevice) "Your account is no longer valid"
    $ div []
      [ p []
        [ text  "We are sorry, but your account is no longer known by our server." ]
      , p []
        [ text
          $ "To proceed I would create a new account for you. You will have to rejoin any "
          <> "families you were in already."
        ]
      , p [] [ text "I am sorry for any inconveniences!" ]
      ]
  AlreadyFamilyMember -> errorView (Just clearError) "You are already a member of this family!"
    $ div []
      [ p [] [ text "You cannot join a family you are already a member of."]
      , p [] [ text $ "If you want to invite another device, please send another invitation."
                    <>"The link you just used, is now invalid! (Security, you know ... )"
             ]
      ]
  ConnectionFailed -> errorView (Just clearError) "No Internet Connection?"
    $ div []
      [ p [] [ text "We cannot reach our server."]
      , p [] [ text "Please make sure that you have a working internet connection and try again."
             ]
      ]
  NoSuchFamily -> errorView (Just clearError) "Your family no longer exists!"
    $ div []
      [ p [] [ text "It probably got deleted, we are sorry about that."]
      ]
  FamilyNotOnline -> errorView (Just clearError) "Your family is not online!"
    $ div []
      [ p [] [ text "This should not happen - like ever, if it happens, this is a bug. It can also happen if you open gonimo on multiple tabs in the same browser - which currently is not prevented (also a shortcoming of the current version)."]
      ]
  InvitationAlreadyClaimed -> errorView (Just clearError) "This invitation is already claimed!"
    $ div []
      [ p [] [ text "Another device already claimed this invitation."]
      , p [] [ text $ "Only this other device is now able to accept or decline the invitation."
             ]
      , p [] [ text "Security and stuff ...." ]
      ]
  NoSuchInvitation -> errorView (Just clearError) "This invitation no longer exists!"
    $ div []
      [ p [] [ text "For security reasons, invitations are only valid once."]
      , p [] [ text $ "Please send a new invitation from a device already in the family you were about to join."
             ]
      ]

errorView :: forall action. ErrorAction action
             => Maybe action -> String -> Html action -> Html action
errorView = errorView' "Proceed"

errorView' :: forall action. ErrorAction action
             => String -> Maybe action -> String -> Html action -> Html action
errorView' btnText action heading body =
    div [ A.className "alert alert-danger", A.role "alert" ]
    $ [ h1 [] [ text heading ]
      , body
      ]
      <> Arr.fromFoldable (map renderButton action)
  where
    renderButton :: action -> Html action
    renderButton action =
      div [ A.className "btn-group", A.role "group" ]
      [ button
        [ A.className "btn btn-danger btn-lg btn-block", E.onClick $ const action ]
        [ text btnText ]
      ]

logError :: forall action m. (ErrorAction action, Applicative m)
                 => String -> String -> m (Array (IO action))
logError prefix msg = pure [ do
                              Gonimo.log $ prefix <> msg
                              pure nop
                           ]

fromServerError :: ServerError -> Maybe UserError
fromServerError err = case err of
    Server.InvalidAuthToken         -> Just DeviceInvalid
    Server.AlreadyFamilyMember      -> Just AlreadyFamilyMember
    Server.NoSuchFamily _           -> Just NoSuchFamily
    Server.FamilyNotOnline _        -> Just FamilyNotOnline
    Server.InvitationAlreadyClaimed -> Just InvitationAlreadyClaimed
    Server.NoSuchInvitation         -> Just NoSuchInvitation
    _                               -> Nothing

-- | Sets userError in state but only if it was NoError before. (Does not overwrite an existing error)
setError :: forall r. UserError -> (State r) -> (State r)
setError error state = case state.userError of
  NoError -> state { userError = error }
  _ -> state


Remove commented code

Remove commented code

module Test.QuickCheck where

import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Eff.Random
import Control.Monad.Eff.Exception

import Test.QuickCheck.LCG

class Arbitrary t where
  arbitrary :: Gen t

class CoArbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

data Result = Success | Failed String

instance showResult :: Show Result where
  show Success = "Success"
  show (Failed msg) = "Failed: " ++ msg

(<?>) :: Boolean -> String -> Result
(<?>) true _ = Success
(<?>) false msg = Failed msg

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: CoArbitrary Number where
  coarbitrary = perturbGen

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = do
    n <- uniform
    return $ (n * 2) < 1

instance coarbBoolean :: CoArbitrary Boolean where
  coarbitrary true (Gen f) = Gen $ \l -> f (l + 1)
  coarbitrary false (Gen f) = Gen $ \l -> f (l + 2)

instance arbFunction :: (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \l -> { value: \a -> (runGen (f a) l).value, newSeed: l }

instance coarbFunction :: (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f xs) gen
    where
    map _ [] = []
    map f (x : xs) = f x : map f xs

instance arbArray :: (Arbitrary a) => Arbitrary [a] where
  arbitrary = do
    b <- arbitrary
    if b then return [] else do
      a <- arbitrary
      as <- arbitrary
      return (a : as)

instance coarbArray :: (CoArbitrary a) => CoArbitrary [a] where
  coarbitrary [] = id
  coarbitrary (x : xs) = coarbitrary xs <<< coarbitrary x

class Testable prop where
  test :: prop -> Gen Result

instance testableResult :: Testable Result where
  test = return

instance testableBoolean :: Testable Boolean where
  test true = return Success
  test false = return $ Failed "Test returned false"

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arbitrary
    test (f t)

quickCheckPure :: forall prop. (Testable prop) => Number -> Number -> prop -> [Result]
quickCheckPure seed n prop = evalGen (go n) seed
  where
  go n | n <= 0 = return []
  go n = do
    result <- test prop
    rest <- go (n - 1)
    return $ result : rest

type QC a = forall eff. Eff (trace :: Trace, random :: Random, err :: Exception String | eff) a

quickCheck' :: forall prop. (Testable prop) => Number -> prop -> QC {}
quickCheck' n prop = do
  seed <- randomSeed
  let results = quickCheckPure seed n prop
  let successes = countSuccesses results
  trace $ show successes ++ "/" ++ show n ++ " test(s) passed."
  throwOnFirstFailure 1 results

  where

  throwOnFirstFailure :: Number -> [Result] -> QC {}
  throwOnFirstFailure _ [] = return {}
  throwOnFirstFailure n (Failed msg : _) = throwException $ "Test " ++ show n ++ " failed: \n" ++ msg
  throwOnFirstFailure n (_ : rest) = throwOnFirstFailure (n + 1) rest

  countSuccesses :: [Result] -> Number
  countSuccesses [] = 0
  countSuccesses (Success : rest) = 1 + countSuccesses rest
  countSuccesses (_ : rest) = countSuccesses rest

quickCheck :: forall prop. (Testable prop) => prop -> QC {}
quickCheck prop = quickCheck' 100 prop

module Test.QuickCheck where

{-
import Data.Array
import Data.Maybe
import Data.Either
import Data.Tuple
-}

import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Eff.Random
import Control.Monad.Eff.Exception

import Test.QuickCheck.LCG

class Arbitrary t where
  arbitrary :: Gen t

class CoArbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

data Result = Success | Failed String

instance showResult :: Show Result where
  show Success = "Success"
  show (Failed msg) = "Failed: " ++ msg

(<?>) :: Boolean -> String -> Result
(<?>) true _ = Success
(<?>) false msg = Failed msg

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: CoArbitrary Number where
  coarbitrary = perturbGen

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = do
    n <- uniform
    return $ (n * 2) < 1

instance coarbBoolean :: CoArbitrary Boolean where
  coarbitrary true (Gen f) = Gen $ \l -> f (l + 1)
  coarbitrary false (Gen f) = Gen $ \l -> f (l + 2)

instance arbFunction :: (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \l -> { value: \a -> (runGen (f a) l).value, newSeed: l }

instance coarbFunction :: (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f xs) gen
    where
    map _ [] = []
    map f (x : xs) = f x : map f xs

instance arbArray :: (Arbitrary a) => Arbitrary [a] where
  arbitrary = do
    b <- arbitrary
    if b then return [] else do
      a <- arbitrary
      as <- arbitrary
      return (a : as)

instance coarbArray :: (CoArbitrary a) => CoArbitrary [a] where
  coarbitrary [] = id
  coarbitrary (x : xs) = coarbitrary xs <<< coarbitrary x

{-
instance arbMaybe :: (Arb a) => Arb (Maybe a) where
  arb = do
    b <- arb
    if b then pure Nothing else Just <$> arb

instance arbEither :: (Arb a, Arb b) => Arb (Either a b) where
  arb = do
    b <- arb
    if b then Left <$> arb else Right <$> arb

instance arbTuple :: (Arb a, Arb b) => Arb (Tuple a b) where
  arb = Tuple <$> arb <*> arb
-}

class Testable prop where
  test :: prop -> Gen Result

instance testableResult :: Testable Result where
  test = return

instance testableBoolean :: Testable Boolean where
  test true = return Success
  test false = return $ Failed "Test returned false"

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arbitrary
    test (f t)

quickCheckPure :: forall prop. (Testable prop) => Number -> Number -> prop -> [Result]
quickCheckPure seed n prop = evalGen (go n) seed
  where
  go n | n <= 0 = return []
  go n = do
    result <- test prop
    rest <- go (n - 1)
    return $ result : rest

type QC a = forall eff. Eff (trace :: Trace, random :: Random, err :: Exception String | eff) a

quickCheck' :: forall prop. (Testable prop) => Number -> prop -> QC {}
quickCheck' n prop = do
  seed <- randomSeed
  let results = quickCheckPure seed n prop
  let successes = countSuccesses results
  trace $ show successes ++ "/" ++ show n ++ " test(s) passed."
  throwOnFirstFailure 1 results

  where

  throwOnFirstFailure :: Number -> [Result] -> QC {}
  throwOnFirstFailure _ [] = return {}
  throwOnFirstFailure n (Failed msg : _) = throwException $ "Test " ++ show n ++ " failed: \n" ++ msg
  throwOnFirstFailure n (_ : rest) = throwOnFirstFailure (n + 1) rest

  countSuccesses :: [Result] -> Number
  countSuccesses [] = 0
  countSuccesses (Success : rest) = 1 + countSuccesses rest
  countSuccesses (_ : rest) = countSuccesses rest

quickCheck :: forall prop. (Testable prop) => prop -> QC {}
quickCheck prop = quickCheck' 100 prop


Fix ace example

Fix ace example

module AceComponent (AceEffects, AceQuery(..), AceOutput(..), aceComponent) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.Maybe (Maybe(..))

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import Ace as Ace
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Types (ACE, Editor)

-- | The state for the ace component - we only need a reference to the editor,
-- | as Ace editor has its own internal state that we can query instead of
-- | replicating it within Halogen.
type AceState =
  { element :: Maybe HTMLElement
  , editor :: Maybe Editor
  }

initAceState :: AceState
initAceState =
  { element: Nothing
  , editor: Nothing
  }

-- | A basic query algebra for the Ace component.
data AceQuery a
  = SetElement (Maybe HTMLElement) a
  | Initialize a
  | Finalize a
  | ChangeText String a
  | HandleChange (Boolean -> a)

data AceOutput = TextChanged String

-- | Effects embedding the Ace editor requires.
type AceEffects eff = (ace :: ACE, avar :: AVAR | eff)

-- | The Ace component definition.
aceComponent :: forall eff. H.Component HH.HTML AceQuery AceOutput (Aff (AceEffects eff))
aceComponent =
  H.lifecycleComponent
    { render
    , eval
    , initialState: initAceState
    , initializer: Just (H.action Initialize)
    , finalizer: Just (H.action Finalize)
    }
  where

  -- As we're embedding a 3rd party component we only need to create a
  -- placeholder div here and attach the ref property which will raise a query
  -- when the element is created.
  render :: AceState -> H.ComponentHTML AceQuery
  render = const $ HH.div [ HP.ref \el -> H.action (SetElement el) ] []

  -- The query algebra for the component handles the initialization of the Ace
  -- editor as well as responding to the `ChangeText` action that allows us to
  -- alter the editor's state.
  eval :: AceQuery ~> H.ComponentDSL AceState AceQuery AceOutput (Aff (AceEffects eff))
  eval (SetElement el next) = do
    H.modify (_ { element = el })
    pure next
  eval (Initialize next) = do
    H.gets _.element >>= case _ of
      Nothing -> pure unit
      Just el' -> do
        editor <- H.liftEff $ Ace.editNode el' Ace.ace
        session <- H.liftEff $ Editor.getSession editor
        H.modify (_ { editor = Just editor })
        H.subscribe $ H.eventSource_ (Session.onChange session) (H.request HandleChange)
    pure next
  eval (Finalize next) = do
    -- Release the reference to the editor and do any other cleanup that a real
    -- world component might need.
    H.modify (_ { editor = Nothing })
    pure next
  eval (ChangeText text next) = do
    maybeEditor <- H.gets _.editor
    case maybeEditor of
      Nothing -> pure unit
      Just editor -> do
        current <- H.liftEff $ Editor.getValue editor
        when (text /= current) do
          void $ H.liftEff $ Editor.setValue text Nothing editor
    H.raise $ TextChanged text
    pure next
  eval (HandleChange continue) = do
    maybeEditor <- H.gets _.editor
    case maybeEditor of
      Nothing -> pure unit
      Just editor -> do
        text <- H.liftEff (Editor.getValue editor)
        H.raise $ TextChanged text
    pure (continue true)

module AceComponent (AceEffects, AceQuery(..), AceOutput(..), aceComponent) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.Maybe (Maybe(..))

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import Ace as Ace
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Types (ACE, Editor)

-- | The state for the ace component - we only need a reference to the editor,
-- | as Ace editor has its own internal state that we can query instead of
-- | replicating it within Halogen.
type AceState =
  { element :: Maybe HTMLElement
  , editor :: Maybe Editor
  }

initAceState :: AceState
initAceState =
  { element: Nothing
  , editor: Nothing
  }

-- | A basic query algebra for the Ace component.
data AceQuery a
  = SetElement (Maybe HTMLElement) a
  | Initialize a
  | Finalize a
  | ChangeText String a

data AceOutput = TextChanged String

-- | Effects embedding the Ace editor requires.
type AceEffects eff = (ace :: ACE, avar :: AVAR | eff)

-- | The Ace component definition.
aceComponent :: forall eff. H.Component HH.HTML AceQuery AceOutput (Aff (AceEffects eff))
aceComponent =
  H.lifecycleComponent
    { render
    , eval
    , initialState: initAceState
    , initializer: Just (H.action Initialize)
    , finalizer: Just (H.action Finalize)
    }
  where

  -- As we're embedding a 3rd party component we only need to create a
  -- placeholder div here and attach the ref property which will raise a query
  -- when the element is created.
  render :: AceState -> H.ComponentHTML AceQuery
  render = const $ HH.div [ HP.ref \el -> H.action (SetElement el) ] []

  -- The query algebra for the component handles the initialization of the Ace
  -- editor as well as responding to the `ChangeText` action that allows us to
  -- alter the editor's state.
  eval :: AceQuery ~> H.ComponentDSL AceState AceQuery AceOutput (Aff (AceEffects eff))
  eval (SetElement el next) = do
    H.modify (_ { element = el })
    pure next
  eval (Initialize next) = do
    H.gets _.element >>= case _ of
      Nothing -> pure unit
      Just el' -> do
        editor <- H.liftEff $ Ace.editNode el' Ace.ace
        session <- H.liftEff $ Editor.getSession editor
        H.modify (_ { editor = Just editor })
        H.subscribe $ H.eventSource_ (Session.onChange session) do
          text <- H.liftEff (Editor.getValue editor)
          pure $ Just $ H.action (ChangeText text)
    pure next
  eval (Finalize next) = do
    -- Release the reference to the editor and do any other cleanup that a real
    -- world component might need.
    H.modify (_ { editor = Nothing })
    pure next
  eval (ChangeText text next) = do
    state <- H.gets _.editor
    case state of
      Nothing -> pure unit
      Just editor -> do
        current <- H.liftEff $ Editor.getValue editor
        when (text /= current) do
          void $ H.liftEff $ Editor.setValue text Nothing editor
    H.raise $ TextChanged text
    pure next


Use `<$>` for LongOpt

Use `<$>` for LongOpt

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

-- | Represent a meta token, derived from a usage line
data Meta
  = Command String
  | Positional String
  | LongOpt String (Maybe String)
  | ShortOpt Char (Array Char) (Maybe String)

-- | Represent a single usage
type Usage = List Meta
type UsageBlock = List Usage

instance showMeta :: Show Meta where
  show (Command name) =
    "Command " ++ name
  show (Positional name) =
    "Positional " ++ name
  show (LongOpt name arg) =
    "LongOpt " ++ name ++ " " ++ show arg
  show (ShortOpt x xs arg) =
    "ShortOpt " ++ (show $ fromChar x ++ fromCharArray xs) ++ " " ++ show arg

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  x <- matches "[A-Z]"
  xs <- Array.many $ matches "[A-Z]"
  return $ fromCharArray $ Array.cons x xs

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  xs <- Array.some $ matches "[a-z]"
  char '>'
  return $ fromCharArray xs

-- | Parse a positional argument
positional :: Parser String Meta
positional = do
  x <- _ARGNAME <|> _argname_
  return $ Positional x

-- | Parse a long option
-- |
-- | --foo
-- | --foo <argument>|ARGUMENT
-- |
longOption :: Parser String Meta
longOption = do
  string "--"
  LongOpt
    <$> (fromCharArray <$> (Array.some $ matches "[a-z]"))
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse a short option
-- |
-- | -v
-- | -vv
-- | -xvzf
-- | -v <argument>|ARGUMENT
-- | -vv <argument>|ARGUMENT
-- | -xvzf <argument>|ARGUMENT
-- |
shortOption :: Parser String Meta
shortOption = do
  char '-'
  ShortOpt
    <$> (matches "[a-z]")
    <*> (Array.many $ matches "[a-z]")
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse any type of option
option :: Parser String Meta
option = longOption <|> shortOption

-- | Parse any valid usage token
usageToken :: Parser String Meta
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do

  -- Program name
  string program <* space
  Position { column: col } <- getPosition

  -- First line of usage tokens
  x <- usageToken `sepBy` many space

  -- And the rest of 'em
  xs <- (many $ try do
          many space *> eol
          indent (col - 1)
          many space
          usageToken `sepBy` many space)

  return $ concat (x:xs)

-- | Parse a complete usage block
-- |
-- | Usage:
-- |    naval-fate -vvv
-- |               -v
-- |    naval-fate --debug
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do
  -- Title
  string "Usage:" <* chompRight

  -- First usage line, indicates indentation
  many space
  Position { column: col } <- getPosition
  x <- usage program

  -- Subsequent usage lines
  xs <- many $ try $ do
    eol
    indent (col - 1)
    usage program <* many space <* eol

  return (x:xs)

meta :: String -> Parser String Unit
meta program = do
  skipSpaces
  x <- usageBlock program
  debug x
  return unit

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

-- | Represent a meta token, derived from a usage line
data Meta
  = Command String
  | Positional String
  | LongOpt String (Maybe String)
  | ShortOpt Char (Array Char) (Maybe String)

-- | Represent a single usage
type Usage = List Meta
type UsageBlock = List Usage

instance showMeta :: Show Meta where
  show (Command name) =
    "Command " ++ name
  show (Positional name) =
    "Positional " ++ name
  show (LongOpt name arg) =
    "LongOpt " ++ name ++ " " ++ show arg
  show (ShortOpt x xs arg) =
    "ShortOpt " ++ (show $ fromChar x ++ fromCharArray xs) ++ " " ++ show arg

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  x <- matches "[A-Z]"
  xs <- Array.many $ matches "[A-Z]"
  return $ fromCharArray $ Array.cons x xs

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  xs <- Array.some $ matches "[a-z]"
  char '>'
  return $ fromCharArray xs

-- | Parse a positional argument
positional :: Parser String Meta
positional = do
  x <- _ARGNAME <|> _argname_
  return $ Positional x

-- | Parse a long option
-- |
-- | --foo
-- | --foo <argument>|ARGUMENT
-- |
longOption :: Parser String Meta
longOption = do
  string "--"
  xs <- Array.some $ matches "[a-z]"
  arg <- (do
    many $ char ' '
    arg <- (_ARGNAME <|> _argname_)
    return $ Just arg) <|> (return Nothing)
  return $ LongOpt (fromCharArray xs) arg

-- | Parse a short option
-- |
-- | -v
-- | -vv
-- | -xvzf
-- | -v <argument>|ARGUMENT
-- | -vv <argument>|ARGUMENT
-- | -xvzf <argument>|ARGUMENT
-- |
shortOption :: Parser String Meta
shortOption = do
  char '-'
  ShortOpt
    <$> (matches "[a-z]")
    <*> (Array.many $ matches "[a-z]")
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse any type of option
option :: Parser String Meta
option = longOption <|> shortOption

-- | Parse any valid usage token
usageToken :: Parser String Meta
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do

  -- Program name
  string program <* space
  Position { column: col } <- getPosition

  -- First line of usage tokens
  x <- usageToken `sepBy` (many space)

  xs <- (many $ try do
    many space *> eol
    indent (col - 1)
    many space
    usageToken `sepBy` many space)

  return $ concat (x:xs)

-- | Parse a complete usage block
-- |
-- | Usage:
-- |    naval-fate -vvv
-- |               -v
-- |    naval-fate --debug
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do
  -- Title
  string "Usage:" <* chompRight

  -- First usage line, indicates indentation
  many space
  Position { column: col } <- getPosition
  x <- usage program

  -- Subsequent usage lines
  xs <- many $ try $ do
    eol
    indent (col - 1)
    usage program <* many space <* eol

  return (x:xs)

meta :: String -> Parser String Unit
meta program = do
  skipSpaces
  x <- usageBlock program
  debug x
  return unit


Add golden ratio (#327)

Add golden ratio (#327)

Fixes #246.

module Insect.Environment
  ( StorageType(..)
  , StoredValue(..)
  , MathFunction
  , FunctionDescription(..)
  , StoredFunction(..)
  , Environment
  , initialEnvironment
  ) where

import Prelude

import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.List.NonEmpty (NonEmptyList(..), length)
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty, (:|))
import Data.Map (Map, fromFoldable)
import Data.Tuple (Tuple(..))

import Quantities (Quantity, ConversionError)
import Quantities as Q

import Insect.Language (EvalError(..), Identifier, Expression)
import Insect.Functions as F

-- | Values can be stored as constants, as constants that are not
-- | displayed when calling `list`, and as user-defined quantities.
data StorageType = Constant | HiddenConstant | UserDefined

derive instance Eq StorageType

-- | A quantity with a given `StorageType`.
data StoredValue = StoredValue StorageType Quantity

-- | Mathematical functions on physical quantities.
type MathFunction = NonEmpty List Quantity → Either EvalError Quantity

-- | Meta information for a function, mostly for pretty printing
data FunctionDescription = BuiltinFunction (Maybe Int) | UserFunction (NonEmpty List Identifier) Expression

-- | A mathematical function with a given `StorageType`.
data StoredFunction = StoredFunction StorageType MathFunction FunctionDescription

-- | The environment consists of identifiers that are mapped to specific
-- | quantities.
type Environment =
  { values    ∷ Map String StoredValue
  , functions ∷ Map String StoredFunction
  }

-- | The initial environment contains a few useful mathematical and physical
-- | constants.
initialEnvironment ∷ Environment
initialEnvironment =
  { values:
      fromFoldable
        [ constVal "alpha"              Q.α
        , constVal "avogadroConstant"   Q.avogadroConstant
        , constVal "bohrMagneton"       Q.µB
        , constVal "boltzmannConstant"  Q.kB
        , constVal "c"                  Q.speedOfLight
        , constVal "e"                  Q.e
        , constVal "electricConstant"   Q.ε0
        , constVal "eps0"               Q.ε0
        , constVal "ε0"                 Q.ε0
        , constVal "elementaryCharge"   Q.electronCharge
        , constVal "electronCharge"     Q.electronCharge
        , constVal "electronMass"       Q.electronMass
        , constVal "G"                  Q.gravitationalConstant
        , constVal "g0"                 Q.g0
        , constVal "goldenRatio"        Q.phi
        , constVal "φ"                  Q.phi
        , constVal "gravity"            Q.g0
        , constVal "h_bar"              Q.ℏ
        , constVal "ℏ"                  Q.ℏ
        , constVal "k_B"                Q.kB
        , constVal "magneticConstant"   Q.µ0
        , constVal "mu0"                Q.µ0
        , constVal "µ0"                 Q.µ0
        , constVal "muB"                Q.µB
        , constVal "µ_B"                Q.µB
        , constVal "N_A"                Q.avogadroConstant
        , constVal "pi"                 Q.pi
        , constVal "π"                  Q.pi
        , constVal "planckConstant"     Q.planckConstant
        , constVal "protonMass"         Q.protonMass
        , constVal "speedOfLight"       Q.speedOfLight
        , constVal "R"                  Q.idealGasConstant

        -- Hidden constants
        , hiddenVal "hundred"     (Q.scalar 1.0e2)
        , hiddenVal "thousand"    (Q.scalar 1.0e3)
        , hiddenVal "million"     (Q.scalar 1.0e6)
        , hiddenVal "billion"     (Q.scalar 1.0e9)
        , hiddenVal "trillion"    (Q.scalar 1.0e12)
        , hiddenVal "quadrillion" (Q.scalar 1.0e15)
        , hiddenVal "quintillion" (Q.scalar 1.0e18)

        , hiddenVal "googol"      (Q.scalar 1.0e100)

        , hiddenVal "tau"         Q.tau
        , hiddenVal "τ"           Q.tau
        ],
    functions:
      fromFoldable
        [ constFunc  "abs" (Q.abs >>> pure)
        , constFunc  "acos" Q.acos
        , constFunc  "acosh" Q.acosh
        , constFunc  "acos" Q.acos
        , constFunc  "acosh" Q.acosh
        , constFunc  "asin" Q.asin
        , constFunc  "asinh" Q.asinh
        , constFunc  "atan" Q.atan
        , constFunc2 "atan2" Q.atan2
        , constFunc  "atanh" Q.atanh
        , constFunc  "ceil" Q.ceil
        , constFunc  "cos" Q.cos
        , constFunc  "cosh" Q.cosh
        , constFunc  "exp" Q.exp
        , constFunc  "floor" Q.floor
        , constFunc  "fromCelsius" F.fromCelsius
        , constFunc  "fromFahrenheit" F.fromFahrenheit
        , constFunc  "gamma" Q.gamma
        , constFunc  "ln" Q.ln
        , constFunc  "log" Q.ln
        , constFunc  "log10" Q.log10
        , constFuncN "minimum" (lmap QConversionError <<< Q.min <<< NonEmptyList)
        , constFuncN "maximum" (lmap QConversionError <<< Q.max <<< NonEmptyList)
        , constFuncN "mean" (lmap QConversionError <<< Q.mean <<< NonEmptyList)
        , constFunc  "round" Q.round
        , constFunc  "sin" Q.sin
        , constFunc  "sinh" Q.sinh
        , constFunc  "sqrt" (Q.sqrt >>> pure)
        , constFunc  "tan" Q.tan
        , constFunc  "tanh" Q.tanh
        , constFunc  "toCelsius" F.toCelsius
        , constFunc  "toFahrenheit" F.toFahrenheit
        ]
  }
  where
    constVal identifier value = Tuple identifier (StoredValue Constant value)
    hiddenVal identifier value = Tuple identifier (StoredValue HiddenConstant value)
    constFunc  identifier func = Tuple identifier (StoredFunction Constant (wrapSimple identifier func) (BuiltinFunction (Just 1)))
    constFunc2 identifier func = Tuple identifier (StoredFunction Constant (wrapSimple2 identifier func) (BuiltinFunction (Just 2)))
    constFuncN identifier func = Tuple identifier (StoredFunction Constant func (BuiltinFunction Nothing))

    wrapSimple ∷ Identifier → (Quantity → Either ConversionError Quantity) → MathFunction
    wrapSimple name func qs =
      case qs of
        x :| Nil → lmap QConversionError $ func x
        _        → Left $ WrongArityError name 1 (length (NonEmptyList qs))

    wrapSimple2 ∷ Identifier → (Quantity → Quantity → Either ConversionError Quantity) → MathFunction
    wrapSimple2 name func qs =
      case qs of
        x1 :| x2 : Nil → lmap QConversionError $ func x1 x2
        _              → Left $ WrongArityError name 2 (length (NonEmptyList qs))

module Insect.Environment
  ( StorageType(..)
  , StoredValue(..)
  , MathFunction
  , FunctionDescription(..)
  , StoredFunction(..)
  , Environment
  , initialEnvironment
  ) where

import Prelude

import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.List.NonEmpty (NonEmptyList(..), length)
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty, (:|))
import Data.Map (Map, fromFoldable)
import Data.Tuple (Tuple(..))

import Quantities (Quantity, ConversionError)
import Quantities as Q

import Insect.Language (EvalError(..), Identifier, Expression)
import Insect.Functions as F

-- | Values can be stored as constants, as constants that are not
-- | displayed when calling `list`, and as user-defined quantities.
data StorageType = Constant | HiddenConstant | UserDefined

derive instance Eq StorageType

-- | A quantity with a given `StorageType`.
data StoredValue = StoredValue StorageType Quantity

-- | Mathematical functions on physical quantities.
type MathFunction = NonEmpty List Quantity → Either EvalError Quantity

-- | Meta information for a function, mostly for pretty printing
data FunctionDescription = BuiltinFunction (Maybe Int) | UserFunction (NonEmpty List Identifier) Expression

-- | A mathematical function with a given `StorageType`.
data StoredFunction = StoredFunction StorageType MathFunction FunctionDescription

-- | The environment consists of identifiers that are mapped to specific
-- | quantities.
type Environment =
  { values    ∷ Map String StoredValue
  , functions ∷ Map String StoredFunction
  }

-- | The initial environment contains a few useful mathematical and physical
-- | constants.
initialEnvironment ∷ Environment
initialEnvironment =
  { values:
      fromFoldable
        [ constVal "alpha"              Q.α
        , constVal "avogadroConstant"   Q.avogadroConstant
        , constVal "bohrMagneton"       Q.µB
        , constVal "boltzmannConstant"  Q.kB
        , constVal "c"                  Q.speedOfLight
        , constVal "e"                  Q.e
        , constVal "electricConstant"   Q.ε0
        , constVal "eps0"               Q.ε0
        , constVal "ε0"                 Q.ε0
        , constVal "elementaryCharge"   Q.electronCharge
        , constVal "electronCharge"     Q.electronCharge
        , constVal "electronMass"       Q.electronMass
        , constVal "G"                  Q.gravitationalConstant
        , constVal "g0"                 Q.g0
        , constVal "gravity"            Q.g0
        , constVal "h_bar"              Q.ℏ
        , constVal "ℏ"                  Q.ℏ
        , constVal "k_B"                Q.kB
        , constVal "magneticConstant"   Q.µ0
        , constVal "mu0"                Q.µ0
        , constVal "µ0"                 Q.µ0
        , constVal "muB"                Q.µB
        , constVal "µ_B"                Q.µB
        , constVal "N_A"                Q.avogadroConstant
        , constVal "pi"                 Q.pi
        , constVal "π"                  Q.pi
        , constVal "planckConstant"     Q.planckConstant
        , constVal "protonMass"         Q.protonMass
        , constVal "speedOfLight"       Q.speedOfLight
        , constVal "R"                  Q.idealGasConstant

        -- Hidden constants
        , hiddenVal "hundred"     (Q.scalar 1.0e2)
        , hiddenVal "thousand"    (Q.scalar 1.0e3)
        , hiddenVal "million"     (Q.scalar 1.0e6)
        , hiddenVal "billion"     (Q.scalar 1.0e9)
        , hiddenVal "trillion"    (Q.scalar 1.0e12)
        , hiddenVal "quadrillion" (Q.scalar 1.0e15)
        , hiddenVal "quintillion" (Q.scalar 1.0e18)

        , hiddenVal "googol"      (Q.scalar 1.0e100)

        , hiddenVal "tau"         Q.tau
        , hiddenVal "τ"           Q.tau
        ],
    functions:
      fromFoldable
        [ constFunc  "abs" (Q.abs >>> pure)
        , constFunc  "acos" Q.acos
        , constFunc  "acosh" Q.acosh
        , constFunc  "acos" Q.acos
        , constFunc  "acosh" Q.acosh
        , constFunc  "asin" Q.asin
        , constFunc  "asinh" Q.asinh
        , constFunc  "atan" Q.atan
        , constFunc2 "atan2" Q.atan2
        , constFunc  "atanh" Q.atanh
        , constFunc  "ceil" Q.ceil
        , constFunc  "cos" Q.cos
        , constFunc  "cosh" Q.cosh
        , constFunc  "exp" Q.exp
        , constFunc  "floor" Q.floor
        , constFunc  "fromCelsius" F.fromCelsius
        , constFunc  "fromFahrenheit" F.fromFahrenheit
        , constFunc  "gamma" Q.gamma
        , constFunc  "ln" Q.ln
        , constFunc  "log" Q.ln
        , constFunc  "log10" Q.log10
        , constFuncN "minimum" (lmap QConversionError <<< Q.min <<< NonEmptyList)
        , constFuncN "maximum" (lmap QConversionError <<< Q.max <<< NonEmptyList)
        , constFuncN "mean" (lmap QConversionError <<< Q.mean <<< NonEmptyList)
        , constFunc  "round" Q.round
        , constFunc  "sin" Q.sin
        , constFunc  "sinh" Q.sinh
        , constFunc  "sqrt" (Q.sqrt >>> pure)
        , constFunc  "tan" Q.tan
        , constFunc  "tanh" Q.tanh
        , constFunc  "toCelsius" F.toCelsius
        , constFunc  "toFahrenheit" F.toFahrenheit
        ]
  }
  where
    constVal identifier value = Tuple identifier (StoredValue Constant value)
    hiddenVal identifier value = Tuple identifier (StoredValue HiddenConstant value)
    constFunc  identifier func = Tuple identifier (StoredFunction Constant (wrapSimple identifier func) (BuiltinFunction (Just 1)))
    constFunc2 identifier func = Tuple identifier (StoredFunction Constant (wrapSimple2 identifier func) (BuiltinFunction (Just 2)))
    constFuncN identifier func = Tuple identifier (StoredFunction Constant func (BuiltinFunction Nothing))

    wrapSimple ∷ Identifier → (Quantity → Either ConversionError Quantity) → MathFunction
    wrapSimple name func qs =
      case qs of
        x :| Nil → lmap QConversionError $ func x
        _        → Left $ WrongArityError name 1 (length (NonEmptyList qs))

    wrapSimple2 ∷ Identifier → (Quantity → Quantity → Either ConversionError Quantity) → MathFunction
    wrapSimple2 name func qs =
      case qs of
        x1 :| x2 : Nil → lmap QConversionError $ func x1 x2
        _              → Left $ WrongArityError name 2 (length (NonEmptyList qs))


add Show Input instance

add Show Input instance

module Types where

import Data.Maybe
import Data.Tuple
import Data.String
import Data.Array (map)
import Control.Monad.Reader.Trans
import Control.Monad.Reader.Class
import Control.Monad.State
import Control.Monad.State.Class

import Utils

-- newtype wrapper is just so that the ReaderT instance works
type Game = {map :: LevelMap, objects :: [GameObject]}
newtype WrappedGame = WrappedGame Game

unwrapGame :: WrappedGame -> Game
unwrapGame (WrappedGame g) = g

type LevelMap = {blocks :: [[Block]]}
data Block = Wall | Empty

newtype Position = Position {x :: Number, y :: Number}

showRecord :: String -> [String] -> String
showRecord name props =
    "(" <> name <> " {" <> joinWith ", " props <> "})"

(.:) :: forall a. (Show a) => String -> a -> String
(.:) name value = name <> ": " <> show value

instance showPosition :: Show Position where
  show (Position p) =
    showRecord "Position" ["x" .: p.x, "y" .: p.y]

data GameObject = GOPlayer Player | GOItem Item

-- instance showGameObject :: Show GameObject where
--   show (GOPlayer p) = "(GOPlayer " <> show p <> ")"
--   show (GOItem i)   = "(GOItem " <> show i <> ")"

newtype Player
  = Player
      { position :: Position
      , direction :: Maybe Direction
      , intendedDirection :: Maybe Direction
      }

instance showPlayer :: Show Player where
  show (Player p) =
    "Player {" <> joinWith ", " props <> "}"
    where
    props = showPair <$>
              [ Tuple "position" $ show p.position
              , Tuple "direction" $ show p.direction
              , Tuple "intendedDirection" $ show p.intendedDirection
              ]
    showPair (Tuple a b) = a <> ": " <> b

type Item
  = { position :: Position
    , itemType :: ItemType
    }

data Direction = Up | Down | Left | Right
data ItemType = LittleDot | BigDot | Cherry

instance showDirection :: Show Direction where
  show Up = "Up"
  show Down = "Down"
  show Left = "Left"
  show Right = "Right"

dirToPos :: Direction -> Position
dirToPos Up    = Position {x:  0, y: -1}
dirToPos Left  = Position {x: -1, y:  0}
dirToPos Right = Position {x:  1, y:  0}
dirToPos Down  = Position {x:  0, y:  1}

add :: Position -> Position -> Position
add (Position p) (Position q) = Position {x: p.x + q.x, y: p.y + q.y}

data Input = Input (Maybe Direction)

instance showInput :: Show Input where
  show (Input x) = "Input (" <> show x <> ")"

data GameUpdate
  = ChangedDirection (Maybe Direction)
  | ChangedIntendedDirection (Maybe Direction)
  | ChangedPosition Position

instance showGameUpdate :: Show GameUpdate where
  show (ChangedDirection x) =
    "ChangedDirection (" <> show x <> ")"
  show (ChangedIntendedDirection x) =
    "ChangedIntendedDirection (" <> show x <> ")"
  show (ChangedPosition x) =
    "ChangedPosition (" <> show x <> ")"

type GameUpdateM a = ReaderT WrappedGame (State [GameUpdate]) a

tell :: GameUpdate -> GameUpdateM Unit
tell gu = modify (unshift gu)

askGame :: GameUpdateM Game
askGame = reader unwrapGame

runGameUpdateM :: forall a. Game -> GameUpdateM a -> Tuple a [GameUpdate]
runGameUpdateM game action =
  runState (runReaderT action (WrappedGame game)) []

execGameUpdateM :: forall a. Game -> GameUpdateM a -> [GameUpdate]
execGameUpdateM game action = snd $ runGameUpdateM game action

module Types where

import Data.Maybe
import Data.Tuple
import Data.String
import Data.Array (map)
import Control.Monad.Reader.Trans
import Control.Monad.Reader.Class
import Control.Monad.State
import Control.Monad.State.Class

import Utils

-- newtype wrapper is just so that the ReaderT instance works
type Game = {map :: LevelMap, objects :: [GameObject]}
newtype WrappedGame = WrappedGame Game

unwrapGame :: WrappedGame -> Game
unwrapGame (WrappedGame g) = g

type LevelMap = {blocks :: [[Block]]}
data Block = Wall | Empty

newtype Position = Position {x :: Number, y :: Number}

showRecord :: String -> [String] -> String
showRecord name props =
    "(" <> name <> " {" <> joinWith ", " props <> "})"

(.:) :: forall a. (Show a) => String -> a -> String
(.:) name value = name <> ": " <> show value

instance showPosition :: Show Position where
  show (Position p) =
    showRecord "Position" ["x" .: p.x, "y" .: p.y]

data GameObject = GOPlayer Player | GOItem Item

-- instance showGameObject :: Show GameObject where
--   show (GOPlayer p) = "(GOPlayer " <> show p <> ")"
--   show (GOItem i)   = "(GOItem " <> show i <> ")"

newtype Player
  = Player
      { position :: Position
      , direction :: Maybe Direction
      , intendedDirection :: Maybe Direction
      }

instance showPlayer :: Show Player where
  show (Player p) =
    "Player {" <> joinWith ", " props <> "}"
    where
    props = showPair <$>
              [ Tuple "position" $ show p.position
              , Tuple "direction" $ show p.direction
              , Tuple "intendedDirection" $ show p.intendedDirection
              ]
    showPair (Tuple a b) = a <> ": " <> b

type Item
  = { position :: Position
    , itemType :: ItemType
    }

data Direction = Up | Down | Left | Right
data ItemType = LittleDot | BigDot | Cherry

instance showDirection :: Show Direction where
  show Up = "Up"
  show Down = "Down"
  show Left = "Left"
  show Right = "Right"

dirToPos :: Direction -> Position
dirToPos Up    = Position {x:  0, y: -1}
dirToPos Left  = Position {x: -1, y:  0}
dirToPos Right = Position {x:  1, y:  0}
dirToPos Down  = Position {x:  0, y:  1}

add :: Position -> Position -> Position
add (Position p) (Position q) = Position {x: p.x + q.x, y: p.y + q.y}

data Input = Input (Maybe Direction)

data GameUpdate
  = ChangedDirection (Maybe Direction)
  | ChangedIntendedDirection (Maybe Direction)
  | ChangedPosition Position

instance showGameUpdate :: Show GameUpdate where
  show (ChangedDirection x) =
    "ChangedDirection (" <> show x <> ")"
  show (ChangedIntendedDirection x) =
    "ChangedIntendedDirection (" <> show x <> ")"
  show (ChangedPosition x) =
    "ChangedPosition (" <> show x <> ")"

type GameUpdateM a = ReaderT WrappedGame (State [GameUpdate]) a

tell :: GameUpdate -> GameUpdateM Unit
tell gu = modify (unshift gu)

askGame :: GameUpdateM Game
askGame = reader unwrapGame

runGameUpdateM :: forall a. Game -> GameUpdateM a -> Tuple a [GameUpdate]
runGameUpdateM game action =
  runState (runReaderT action (WrappedGame game)) []

execGameUpdateM :: forall a. Game -> GameUpdateM a -> [GameUpdate]
execGameUpdateM game action = snd $ runGameUpdateM game action


Add 'Show' instance to 'Path' type

Add 'Show' instance to 'Path' type

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl, foldMap, any)

import Math (pow)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | End

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

mapWithPath :: Path -> (Expr -> Maybe Expr) -> Expr -> Maybe Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> Just e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> Just op
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> Just es
    _               -> Nothing
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    _               -> Nothing
  go (Nth n p) e = case e of
    List es  -> List  <$> mapMaybeIndex n (go p) es
    App e es -> App e <$> mapMaybeIndex n (go p) es
    _        -> Nothing

mapMaybeIndex :: forall m a. Number -> (a -> Maybe a) -> [a] -> Maybe [a]
mapMaybeIndex i f as = do
  a <- (as !! i) >>= f
  return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (Atom (Name name))            -> apply env name []
  (App (Binary Composition f g) [e]) -> Just $ App f [App g [e]]
  (App (Lambda binds body) args) -> matchls binds args body
  (App (SectL e1 op) [e2])      -> Just $ Binary op e1 e2
  (App (SectR op e2) [e1])      -> Just $ Binary op e1 e2
  (App (Prefix op) [e1, e2])    -> Just $ Binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  (App (App func es) es')       -> Just $ App func (es ++ es')
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Power (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Mod (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i > j

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

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

  go Dollar f e = Just $ App f [e]

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls []     es     expr = Just $ App expr es
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ConsLit b bs)   (Binary Cons e es) = match b e *> match bs es
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match (ListLit (b:bs)) (Binary Cons e es) = match b e *> match (ListLit bs) es
match _                _                = lift Nothing

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs

isNameBound :: String -> Binding -> Boolean
isNameBound name binding = (elemIndex name $ boundNames binding) >= 0

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    l@(Lambda binds body) -> if any (isNameBound name) binds
                               then l
                               else Lambda binds (go body)
    (App func exprs)    -> App (go func) (go <$> exprs)
    e                   -> e

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl, foldMap, any)

import Math (pow)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | End

mapWithPath :: Path -> (Expr -> Maybe Expr) -> Expr -> Maybe Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> Just e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> Just op
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> Just es
    _               -> Nothing
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    _               -> Nothing
  go (Nth n p) e = case e of
    List es  -> List  <$> mapMaybeIndex n (go p) es
    App e es -> App e <$> mapMaybeIndex n (go p) es
    _        -> Nothing

mapMaybeIndex :: forall m a. Number -> (a -> Maybe a) -> [a] -> Maybe [a]
mapMaybeIndex i f as = do
  a <- (as !! i) >>= f
  return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (Atom (Name name))            -> apply env name []
  (App (Binary Composition f g) [e]) -> Just $ App f [App g [e]]
  (App (Lambda binds body) args) -> matchls binds args body
  (App (SectL e1 op) [e2])      -> Just $ Binary op e1 e2
  (App (SectR op e2) [e1])      -> Just $ Binary op e1 e2
  (App (Prefix op) [e1, e2])    -> Just $ Binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  (App (App func es) es')       -> Just $ App func (es ++ es')
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Power (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Mod (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i > j

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

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

  go Dollar f e = Just $ App f [e]

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls []     es     expr = Just $ App expr es
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ConsLit b bs)   (Binary Cons e es) = match b e *> match bs es
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match (ListLit (b:bs)) (Binary Cons e es) = match b e *> match (ListLit bs) es
match _                _                = lift Nothing

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs

isNameBound :: String -> Binding -> Boolean
isNameBound name binding = (elemIndex name $ boundNames binding) >= 0

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    l@(Lambda binds body) -> if any (isNameBound name) binds
                               then l
                               else Lambda binds (go body)
    (App func exprs)    -> App (go func) (go <$> exprs)
    e                   -> e


Remove old TODO

Remove old TODO

module Language.PureScript.TypeChecker.Monad where

import Language.PureScript.Declarations (canonicalizeDictionary)
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

import Data.Array (map)
import Data.Either
import Data.Maybe
import Data.Tuple

import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.Error.Proxy
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.State.Trans
import Control.Monad.Trans
import Control.Monad.Unify

import qualified Data.Map as M

-- |
-- Temporarily bind a collection of names to values
--
bindNames :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Tuple ModuleName Ident) (Tuple Type NameKind) -> m a -> m a
bindNames newNames action = do
  CheckState orig <- get
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = newNames `M.union` (envObj st.env).names } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = (envObj orig.env).names } }
  return a

-- |
-- Temporarily bind a collection of names to types
--
bindTypes :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Qualified ProperName) (Tuple Kind TypeKind) -> m a -> m a
bindTypes newNames action = do
  CheckState orig <- get
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = newNames `M.union` (envObj st.env).types } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = (envObj orig.env).types } }
  return a

-- |
-- Temporarily make a collection of type class dictionaries available
--
withTypeClassDictionaries :: forall m a. (Monad m, MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
withTypeClassDictionaries entries action = do
  CheckState orig <- get
  let mentries = M.fromList $ flip map entries $ \entry -> case entry of
                     TypeClassDictionaryInScope { name = (Qualified mn _) } ->
                       Tuple (Tuple (canonicalizeDictionary entry) mn) entry
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj st.env).typeClassDictionaries `M.union` mentries } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj orig.env).typeClassDictionaries } }
  return a

-- |
-- Get the currently available list of type class dictionaries
--
getTypeClassDictionaries :: forall m. (Monad m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
getTypeClassDictionaries = M.values <<< (\(CheckState st) -> (envObj st.env).typeClassDictionaries) <$> get

-- |
-- Temporarily bind a collection of names to local variables
--
bindLocalVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple Ident Type] -> m a -> m a
bindLocalVariables moduleName bindings =
  bindNames (M.fromList $ flip map bindings $ \(Tuple name ty) -> Tuple (Tuple moduleName name) (Tuple ty LocalVariable))

-- |
-- Temporarily bind a collection of names to local type variables
--
bindLocalTypeVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple ProperName Kind] -> m a -> m a
bindLocalTypeVariables moduleName bindings =
  bindTypes (M.fromList $ flip map bindings $ \(Tuple pn kind) -> Tuple (Qualified (Just moduleName) pn) (Tuple kind LocalTypeVariable))

-- |
-- Lookup the type of a value by name in the @Environment@
--
lookupVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => WithErrorType e -> ModuleName -> Qualified Ident -> m Type
lookupVariable errorType currentModule (Qualified moduleName var) = do
  Environment env <- getEnv
  case M.lookup (Tuple (fromMaybe currentModule moduleName) var) env.names of
    Nothing -> throwError $ withErrorType errorType $ strMsg $ show var ++ " is undefined"
    Just (Tuple ty _) -> return ty

-- |
-- Lookup the kind of a type by name in the @Environment@
--
lookupTypeVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => WithErrorType e -> ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable errorType currentModule (Qualified moduleName name) = do
  Environment env <- getEnv
  case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) env.types of
    Nothing -> throwError $ withErrorType errorType $ strMsg $ "Type variable " ++ show name ++ " is undefined"
    Just (Tuple k _) -> return k

-- |
-- State required for type checking:
--
data CheckState = CheckState {
  -- |
  -- The current @Environment@
  --
    env :: Environment
  -- |
  -- The next fresh unification variable name
  --
  , nextVar :: Number
  -- |
  -- The next type class dictionary name
  --
  , nextDictName :: Number
  -- |
  -- The current module
  --
  , currentModule :: Maybe ModuleName
  }

-- |
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
data Check a = Check (StateT CheckState (Either ErrorStack) a)

unCheck :: forall a. Check a -> StateT CheckState (Either ErrorStack) a
unCheck (Check x) = x

instance functorCheck :: Functor Check where
  (<$>) f (Check x) = Check (f <$> x)

instance applyCheck :: Apply Check where
  (<*>) (Check f) (Check x) = Check (f <*> x)

instance applicativeCheck :: Applicative Check where
  pure a = Check (pure a)

instance bindCheck :: Bind Check where
  (>>=) (Check x) f = Check (x >>= unCheck <<< f)

instance monadCheck :: Monad Check

instance monadErrorCheck :: MonadError ErrorStack Check where
  throwError = Check <<< throwError
  catchError e f = Check $ catchError (unCheck e) (unCheck <<< f)

instance monadStateCheck :: MonadState CheckState Check where
  state = Check <<< state

-- |
-- Get the current @Environment@
--
getEnv :: forall m. (Monad m, MonadState CheckState m) => m Environment
getEnv = (\(CheckState st) -> st.env) <$> get

-- |
-- Update the @Environment@
--
putEnv :: forall m. (Monad m, MonadState CheckState m) => Environment -> m Unit
putEnv env = modify $ \(CheckState st) -> CheckState $ st { env = env }

-- |
-- Modify the @Environment@
--
modifyEnv :: forall m. (Monad m, MonadState CheckState m) => (Environment -> Environment) -> m Unit
modifyEnv f = modify (\(CheckState st) -> CheckState $ st { env = f st.env })

-- |
-- Get the current module name
--
getCurrentModule :: forall m. (Monad m, MonadState CheckState m) => m (Maybe ModuleName)
getCurrentModule = (\(CheckState st) -> st.currentModule) <$> get

-- |
-- Run a computation in the Check monad, starting with an empty @Environment@
--
runCheck :: forall a. Options -> Check a -> Either String (Tuple a Environment)
runCheck opts = runCheck' opts initEnvironment

-- |
-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
--
runCheck' :: forall a. Options -> Environment -> Check a -> Either String (Tuple a Environment)
runCheck' (Options o) env c = stringifyErrorStack o.verboseErrors $ do
  (Tuple a (CheckState st)) <- flip runStateT (CheckState { env: env, nextVar: 0, nextDictName: 0, currentModule: Nothing }) $ unCheck c
  return $ Tuple a (st.env)

-- |
-- Make an assertion, failing with an error message
--
guardWith :: forall e m. (Monad m, MonadError e m) => e -> Boolean -> m Unit
guardWith _ true = return unit
guardWith e false = throwError e

-- |
-- Generate new type class dictionary name
--
freshDictionaryName :: Check Number
freshDictionaryName = do
  n <- (\(CheckState st) -> st.nextDictName) <$> get
  modify $ \(CheckState st) -> CheckState $ st { nextDictName = st.nextDictName + 1 }
  return n

-- |
-- Lift a computation in the @Check@ monad into the substitution monad.
--
liftCheck :: forall a t. Check a -> UnifyT t Check a
liftCheck = UnifyT <<< lift

-- |
-- Run a computation in the substitution monad, generating a return value and the final substitution.
--
liftUnify :: forall t a. (Partial t) => UnifyT t Check a -> Check (Tuple a (Substitution t))
liftUnify unify = do
  CheckState st <- get
  Tuple a (UnifyState ust) <- runUnify (UnifyState $ (unifyStateObj defaultUnifyState) { nextVar = st.nextVar }) unify
  modify $ \(CheckState st') -> CheckState $ st' { nextVar = ust.nextVar }
  return $ Tuple a ust.currentSubstitution

module Language.PureScript.TypeChecker.Monad where

import Language.PureScript.Declarations (canonicalizeDictionary)
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

import Data.Array (map)
import Data.Either
import Data.Maybe
import Data.Tuple

import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.Error.Proxy
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.State.Trans
import Control.Monad.Trans
import Control.Monad.Unify

import qualified Data.Map as M

-- |
-- Temporarily bind a collection of names to values
--
bindNames :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Tuple ModuleName Ident) (Tuple Type NameKind) -> m a -> m a
bindNames newNames action = do
  CheckState orig <- get
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = newNames `M.union` (envObj st.env).names } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = (envObj orig.env).names } }
  return a

-- |
-- Temporarily bind a collection of names to types
--
bindTypes :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Qualified ProperName) (Tuple Kind TypeKind) -> m a -> m a
bindTypes newNames action = do
  CheckState orig <- get
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = newNames `M.union` (envObj st.env).types } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = (envObj orig.env).types } }
  return a
-- |
-- Temporarily make a collection of type class dictionaries available
--
withTypeClassDictionaries :: forall m a. (Monad m, MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
withTypeClassDictionaries entries action = do
  CheckState orig <- get
  let mentries = M.fromList $ flip map entries $ \entry -> case entry of
                     TypeClassDictionaryInScope { name = (Qualified mn _) } ->
                       Tuple (Tuple (canonicalizeDictionary entry) mn) entry
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj st.env).typeClassDictionaries `M.union` mentries } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj orig.env).typeClassDictionaries } }
  return a

-- |
-- Get the currently available list of type class dictionaries
--
getTypeClassDictionaries :: forall m. (Monad m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
getTypeClassDictionaries = M.values <<< (\(CheckState st) -> (envObj st.env).typeClassDictionaries) <$> get

-- |
-- Temporarily bind a collection of names to local variables
--
bindLocalVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple Ident Type] -> m a -> m a
bindLocalVariables moduleName bindings =
  bindNames (M.fromList $ flip map bindings $ \(Tuple name ty) -> Tuple (Tuple moduleName name) (Tuple ty LocalVariable))

-- |
-- Temporarily bind a collection of names to local type variables
--
bindLocalTypeVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple ProperName Kind] -> m a -> m a
bindLocalTypeVariables moduleName bindings =
  bindTypes (M.fromList $ flip map bindings $ \(Tuple pn kind) -> Tuple (Qualified (Just moduleName) pn) (Tuple kind LocalTypeVariable))

-- |
-- Lookup the type of a value by name in the @Environment@
--
lookupVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => WithErrorType e -> ModuleName -> Qualified Ident -> m Type
lookupVariable errorType currentModule (Qualified moduleName var) = do
  Environment env <- getEnv
  case M.lookup (Tuple (fromMaybe currentModule moduleName) var) env.names of
    Nothing -> throwError $ withErrorType errorType $ strMsg $ show var ++ " is undefined"
    Just (Tuple ty _) -> return ty

-- |
-- Lookup the kind of a type by name in the @Environment@
--
lookupTypeVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => WithErrorType e -> ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable errorType currentModule (Qualified moduleName name) = do
  Environment env <- getEnv
  case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) env.types of
    Nothing -> throwError $ withErrorType errorType $ strMsg $ "Type variable " ++ show name ++ " is undefined"
    Just (Tuple k _) -> return k

-- |
-- State required for type checking:
--
data CheckState = CheckState {
  -- |
  -- The current @Environment@
  --
    env :: Environment
  -- |
  -- The next fresh unification variable name
  --
  , nextVar :: Number
  -- |
  -- The next type class dictionary name
  --
  , nextDictName :: Number
  -- |
  -- The current module
  --
  , currentModule :: Maybe ModuleName
  }

-- |
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
data Check a = Check (StateT CheckState (Either ErrorStack) a)
-- TODO: deriving MonadPlus

unCheck :: forall a. Check a -> StateT CheckState (Either ErrorStack) a
unCheck (Check x) = x

instance functorCheck :: Functor Check where
  (<$>) f (Check x) = Check (f <$> x)

instance applyCheck :: Apply Check where
  (<*>) (Check f) (Check x) = Check (f <*> x)

instance applicativeCheck :: Applicative Check where
  pure a = Check (pure a)

instance bindCheck :: Bind Check where
  (>>=) (Check x) f = Check (x >>= unCheck <<< f)

instance monadCheck :: Monad Check

instance monadErrorCheck :: MonadError ErrorStack Check where
  throwError = Check <<< throwError
  catchError e f = Check $ catchError (unCheck e) (unCheck <<< f)

instance monadStateCheck :: MonadState CheckState Check where
  state = Check <<< state

-- |
-- Get the current @Environment@
--
getEnv :: forall m. (Monad m, MonadState CheckState m) => m Environment
getEnv = (\(CheckState st) -> st.env) <$> get

-- |
-- Update the @Environment@
--
putEnv :: forall m. (Monad m, MonadState CheckState m) => Environment -> m Unit
putEnv env = modify $ \(CheckState st) -> CheckState $ st { env = env }

-- |
-- Modify the @Environment@
--
modifyEnv :: forall m. (Monad m, MonadState CheckState m) => (Environment -> Environment) -> m Unit
modifyEnv f = modify (\(CheckState st) -> CheckState $ st { env = f st.env })

-- |
-- Get the current module name
--
getCurrentModule :: forall m. (Monad m, MonadState CheckState m) => m (Maybe ModuleName)
getCurrentModule = (\(CheckState st) -> st.currentModule) <$> get

-- |
-- Run a computation in the Check monad, starting with an empty @Environment@
--
runCheck :: forall a. Options -> Check a -> Either String (Tuple a Environment)
runCheck opts = runCheck' opts initEnvironment

-- |
-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
--
runCheck' :: forall a. Options -> Environment -> Check a -> Either String (Tuple a Environment)
runCheck' (Options o) env c = stringifyErrorStack o.verboseErrors $ do
  (Tuple a (CheckState st)) <- flip runStateT (CheckState { env: env, nextVar: 0, nextDictName: 0, currentModule: Nothing }) $ unCheck c
  return $ Tuple a (st.env)

-- |
-- Make an assertion, failing with an error message
--
guardWith :: forall e m. (Monad m, MonadError e m) => e -> Boolean -> m Unit
guardWith _ true = return unit
guardWith e false = throwError e

-- |
-- Generate new type class dictionary name
--
freshDictionaryName :: Check Number
freshDictionaryName = do
  n <- (\(CheckState st) -> st.nextDictName) <$> get
  modify $ \(CheckState st) -> CheckState $ st { nextDictName = st.nextDictName + 1 }
  return n

-- |
-- Lift a computation in the @Check@ monad into the substitution monad.
--
liftCheck :: forall a t. Check a -> UnifyT t Check a
liftCheck = UnifyT <<< lift

-- |
-- Run a computation in the substitution monad, generating a return value and the final substitution.
--
liftUnify :: forall t a. (Partial t) => UnifyT t Check a -> Check (Tuple a (Substitution t))
liftUnify unify = do
  CheckState st <- get
  Tuple a (UnifyState ust) <- runUnify (UnifyState $ (unifyStateObj defaultUnifyState) { nextVar = st.nextVar }) unify
  modify $ \(CheckState st') -> CheckState $ st' { nextVar = ust.nextVar }
  return $ Tuple a ust.currentSubstitution


more work

more work

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)

data Foo = X | Y

what :: Foo -> Int -> Boolean -> Foo
what x = case _, x, _ of
    0, X, true -> X
    0, Y, true -> X
    _, _, _ -> Y

guu a = case _ of
    true  | a -> "yes"
    false | a -> "no"

muu a = case _ of
    true  -> "yes"
    false -> "no"

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  let tmp = what Y 0 true
  log "Done"

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)

data Foo = X | Y

what ∷ Foo → Int → Boolean → Foo
what x = case _, x, _ of
  0, X, true → X
  0, Y, true → X
  _, _, _ → Y

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  let tmp = what Y 0 true
  log "Done"