Fixed some error messages

Fixed some error messages

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(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, 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
  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
    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

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(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, 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
  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
    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 $ "We 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."]
      ]
  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


Package name option for Go

Package name option for Go

module Language.Golang
    ( renderer
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Renderer, blank, combineNames, forEachTopLevel_, forbidNamer, getOptionValue, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isClass, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap, unionToList)
import Options (Option, stringOption)
import Utils (mapM, sortByKeyM, sortByKey)

packageOption :: Option String
packageOption = stringOption "package" "The name for the generated package" "NAME" "main"

renderer :: Renderer
renderer =
    { displayName: "Go"
    , names: [ "go", "golang" ]
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , options: [packageOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = goNameStyle $ combineNames names

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNoInformation -> noComment "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

goNameStyle :: String -> String
goNameStyle = legalize >>> camelCase >>> startWithLetter isLetterOrUnderscore true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    packageName <- getOptionValue packageOption
    line $ "package " <> packageName
    blank
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    blank
    renderRenderItems blank (Just renderTopLevel) renderGolangType (Just renderGolangUnion)
    unless (unions == L.Nil) do
        blank
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""

renderTopLevel :: String -> IRType -> Doc Unit
renderTopLevel topLevelName topLevelType = do
    { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
    line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
    line $ "    var r " <> topLevelName
    line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
    line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
    indent do
        line "return json.Marshal(r)"
    line "}"

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: String -> Map String IRType -> Doc Unit
renderGolangType className properties = do
    let propertyNames = transformPropertyNames (simpleNamer goNameStyle) ("Other" <> _) [] properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRUnionRep -> Maybe IRType)
compoundPredicates = [unionHasArray, unionHasClass, unionHasMap]

renderGolangUnion :: String -> IRUnionRep -> Doc Unit
renderGolangUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    let isNullableString = if hasNull then "true" else "false"
    fields <- unionToList nonNullUnion # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderNullableToGolang t
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name' _ -> do
            indent do
                line $ "x." <> name' <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let element = unionHasClass unionRep
            in
                case element of
                Just t -> do
                    name' <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name' rendered
                Nothing -> pure unit
        maybeAssignNil p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                line $ "x." <> name' <> " = nil"
            Nothing -> pure unit
        predicateForType :: IRType -> IRUnionRep -> Maybe IRType
        predicateForType t ur =
            if isUnionMember t ur then Just t else Nothing
        makeArgs :: ((IRUnionRep -> Maybe IRType) -> Doc String) -> ((IRUnionRep -> Maybe IRType) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ map predicateForType [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound compoundPredicates
            pure $ intercalate ", " $ A.concat [primitiveArgs, compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRUnionRep -> Maybe IRType) -> Doc String
        memberArg notPresentValue renderPresent p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                pure $ renderPresent t name'
            Nothing -> pure notPresentValue
        primitiveUnmarshalArg p =
            memberArg "nil" (\_ n -> "&x." <> n) p
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        primitiveMarshalArg p =
            memberArg "nil" (\_ n -> "x." <> n) p
        compoundMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p

module Language.Golang
    ( renderer
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Renderer, blank, combineNames, forEachTopLevel_, forbidNamer, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isClass, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap, unionToList)
import Utils (mapM, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { displayName: "Go"
    , names: [ "go", "golang" ]
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = goNameStyle $ combineNames names

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNoInformation -> noComment "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

goNameStyle :: String -> String
goNameStyle = legalize >>> camelCase >>> startWithLetter isLetterOrUnderscore true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    blank
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    blank
    renderRenderItems blank (Just renderTopLevel) renderGolangType (Just renderGolangUnion)
    unless (unions == L.Nil) do
        blank
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""

renderTopLevel :: String -> IRType -> Doc Unit
renderTopLevel topLevelName topLevelType = do
    { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
    line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
    line $ "    var r " <> topLevelName
    line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
    line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
    indent do
        line "return json.Marshal(r)"
    line "}"

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: String -> Map String IRType -> Doc Unit
renderGolangType className properties = do
    let propertyNames = transformPropertyNames (simpleNamer goNameStyle) ("Other" <> _) [] properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRUnionRep -> Maybe IRType)
compoundPredicates = [unionHasArray, unionHasClass, unionHasMap]

renderGolangUnion :: String -> IRUnionRep -> Doc Unit
renderGolangUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    let isNullableString = if hasNull then "true" else "false"
    fields <- unionToList nonNullUnion # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderNullableToGolang t
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name' _ -> do
            indent do
                line $ "x." <> name' <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let element = unionHasClass unionRep
            in
                case element of
                Just t -> do
                    name' <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name' rendered
                Nothing -> pure unit
        maybeAssignNil p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                line $ "x." <> name' <> " = nil"
            Nothing -> pure unit
        predicateForType :: IRType -> IRUnionRep -> Maybe IRType
        predicateForType t ur =
            if isUnionMember t ur then Just t else Nothing
        makeArgs :: ((IRUnionRep -> Maybe IRType) -> Doc String) -> ((IRUnionRep -> Maybe IRType) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ map predicateForType [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound compoundPredicates
            pure $ intercalate ", " $ A.concat [primitiveArgs, compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRUnionRep -> Maybe IRType) -> Doc String
        memberArg notPresentValue renderPresent p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                pure $ renderPresent t name'
            Nothing -> pure notPresentValue
        primitiveUnmarshalArg p =
            memberArg "nil" (\_ n -> "&x." <> n) p
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        primitiveMarshalArg p =
            memberArg "nil" (\_ n -> "x." <> n) p
        compoundMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p


fix "infinite loader" bug

fix "infinite loader" bug

module Components.BooksDirectory (booksDirectory) where

import Common.Monad
import Common.OneDriveApi
import Common.React
import Common.Settings
import qualified Components.AjaxLoader as AjaxLoader
import qualified Components.ChooseDirectoryModal as ChooseDirectoryModal
import qualified Components.OneDriveFileTree as FileTree
import Control.Monad.Aff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Maybe.Trans
import Control.Error.Util
import Data.Foldable
import Data.Lens
import Data.Maybe
import qualified Data.String as S
import Data.Tuple
import Network.HTTP.Affjax
import Prelude
import qualified React as R
import qualified React.DOM as R
import qualified React.DOM.Props as RP
import qualified Thermite as T

import qualified Components.Wrappers.Button as Button
import qualified Components.Wrappers.Glyphicon as Glyphicon
import qualified Libs.PouchDB as DB

type Props =
  { onedriveToken :: String
  , db :: Maybe DB.PouchDB
  }

type State =
  { modalState :: ChooseDirectoryModal.State
  , stateLoaded :: Boolean
  , directory :: Maybe DirectoryInfo
  }

modalState :: LensP State ChooseDirectoryModal.State
modalState =
  lens _.modalState (_ { modalState = _ })

directory :: LensP State (Maybe DirectoryInfo)
directory =
  lens _.directory (_ { directory = _ })

defaultState :: State
defaultState =
  { modalState: ChooseDirectoryModal.defaultState
  , stateLoaded: false
  , directory: Nothing
  }

type Action =
  ChooseDirectoryModal.Action

type DirectoryInfo =
  { itemId :: Maybe String
  , path :: String
  }

type ChoosedDirectoryProps =
  { directory :: DirectoryInfo
  , onedriveToken :: String
  , db :: DB.PouchDB
  }

choosedDirectory :: forall eff. T.Spec (ajax :: AJAX, err :: EXCEPTION, pouchdb :: DB.POUCHDB | eff) State ChoosedDirectoryProps Action
choosedDirectory =
  wrapMiddle $ T.simpleSpec T.defaultPerformAction render
  where
    render dispatch props _ _ =
      [ R.span
        [ RP.className "default" ]
        [ R.text props.directory.path ]
      , Button.button
        { onClick: dispatch ChooseDirectoryModal.ShowModal
        , bsStyle: "link"
        }
        [ R.text "Choose another" ]
      ]

    convertProps p =
      { onedriveToken: p.onedriveToken
      , db: p.db
      }

wrapMiddle :: forall eff state props action. T.Spec eff state props action -> T.Spec eff state props action
wrapMiddle =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      [ R.div
        [ RP.className "col-md-offset-5" ]
        (origRender dispatch p s c)
      ]

chooseButton :: forall eff. T.Spec eff State Props Action
chooseButton =
  wrapMiddle $ T.simpleSpec T.defaultPerformAction render
  where
    render :: T.Render State Props Action
    render dispatch _ _ _ =
      let
        buttonProps =
          { bsSize : "large"
          , onClick : dispatch ChooseDirectoryModal.ShowModal
          }
      in
       [ Button.button buttonProps
         [ R.div
           [ RP.className "col-md-2" ]
           [ Glyphicon.glyphicon' "book"
           , R.text " Choose books directory..."
           ]
         ]
       ]

spec :: forall eff. T.Spec (ajax :: AJAX, err :: EXCEPTION, pouchdb :: DB.POUCHDB | eff) State Props Action
spec =
  fold
  [ T.withState (\st ->
                  if not st.stateLoaded
                  then AjaxLoader.spec
                  else
                    case st.directory of
                      Nothing ->
                        chooseButton
                      Just _ ->
                        mapPropsWithState tryGetChoosedDirectoryProps $ maybeProps choosedDirectory
                )
  , T.simpleSpec performAction T.defaultRender
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focusState modalState ChooseDirectoryModal.spec
  ]
  where
    tryGetChoosedDirectoryProps p s = do
      dir <- s.directory
      db <- p.db
      return { onedriveToken: p.onedriveToken
             , directory: dir
             , db
             }

    tryGetChooseDirectoryModalProps p = do
      db <- p.db
      return { onedriveToken: p.onedriveToken
             , db
             }

    performAction (ChooseDirectoryModal.FileTreeAction action) props state update =
      processFileTreeAction action props state update
    performAction _ _ _ _ =
      pure unit

    processFileTreeAction action props state update =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          launchAff $ do
            (liftEff' $ update $ \s -> s { directory = Nothing, stateLoaded = false }) >>= guardEither
            dir <- getDirectoryInfo props.onedriveToken itemId
            (liftEff' $ update $ \s -> s { directory = Just dir, stateLoaded = true }) >>= guardEither
        _ ->
          pure unit

reactClass :: R.ReactClass Props
reactClass =
  R.createClass reactSpec.spec { componentDidMount = componentDidMount }
  where
    reactSpec =
      T.createReactSpec spec defaultState

    componentDidMount this = launchAff $ do
      props <- liftEff $ R.getProps this
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        maybeSettings <- lift $ tryGetSettings db
        case maybeSettings of
          Nothing ->
            liftEff $ R.transformState this (_ { directory = Nothing, stateLoaded = true })
          Just settings -> do
            dir <- lift $ getDirectoryInfo props.onedriveToken $ getBooksDirectory settings
            liftEff $ R.transformState this (_ { directory = Just dir, stateLoaded = true })
      where
        getBooksDirectory (Settings s) = s.booksDirectory

booksDirectory :: Props -> R.ReactElement
booksDirectory props =
  R.createElement reactClass props []

getDirectoryInfo :: forall e. String -> Maybe String -> Aff (ajax :: AJAX | e) DirectoryInfo
getDirectoryInfo token itemId = do
  item <- getItem <$> getOneDriveItem token itemId
  let parentPath = fromMaybe "" (getPath <$> item.parentReference)
  return { itemId, path: parentPath ++ "/" ++ item.name }
  where
    getItem (OneDriveItem item) = item
    getPath (ItemReference reference) =
      let
        idx = S.indexOf ":" reference.path
      in
       maybe reference.path (\i -> S.drop (i + 1) reference.path) idx

module Components.BooksDirectory (booksDirectory) where

import Common.Monad
import Common.OneDriveApi
import Common.React
import Common.Settings
import qualified Components.AjaxLoader as AjaxLoader
import qualified Components.ChooseDirectoryModal as ChooseDirectoryModal
import qualified Components.OneDriveFileTree as FileTree
import Control.Monad.Aff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Maybe.Trans
import Control.Error.Util
import Data.Foldable
import Data.Lens
import Data.Maybe
import qualified Data.String as S
import Data.Tuple
import Network.HTTP.Affjax
import Prelude
import qualified React as R
import qualified React.DOM as R
import qualified React.DOM.Props as RP
import qualified Thermite as T

import qualified Components.Wrappers.Button as Button
import qualified Components.Wrappers.Glyphicon as Glyphicon
import qualified Libs.PouchDB as DB

type Props =
  { onedriveToken :: String
  , db :: Maybe DB.PouchDB
  }

type State =
  { modalState :: ChooseDirectoryModal.State
  , stateLoaded :: Boolean
  , directory :: Maybe DirectoryInfo
  }

modalState :: LensP State ChooseDirectoryModal.State
modalState =
  lens _.modalState (_ { modalState = _ })

directory :: LensP State (Maybe DirectoryInfo)
directory =
  lens _.directory (_ { directory = _ })

defaultState :: State
defaultState =
  { modalState: ChooseDirectoryModal.defaultState
  , stateLoaded: false
  , directory: Nothing
  }

type Action =
  ChooseDirectoryModal.Action

type DirectoryInfo =
  { itemId :: Maybe String
  , path :: String
  }

type ChoosedDirectoryProps =
  { directory :: DirectoryInfo
  , onedriveToken :: String
  , db :: DB.PouchDB
  }

choosedDirectory :: forall eff. T.Spec (ajax :: AJAX, err :: EXCEPTION, pouchdb :: DB.POUCHDB | eff) State ChoosedDirectoryProps Action
choosedDirectory =
  wrapMiddle $ T.simpleSpec T.defaultPerformAction render
  where
    render dispatch props _ _ =
      [ R.span
        [ RP.className "default" ]
        [ R.text props.directory.path ]
      , Button.button
        { onClick: dispatch ChooseDirectoryModal.ShowModal
        , bsStyle: "link"
        }
        [ R.text "Choose another" ]
      ]

    convertProps p =
      { onedriveToken: p.onedriveToken
      , db: p.db
      }

wrapMiddle :: forall eff state props action. T.Spec eff state props action -> T.Spec eff state props action
wrapMiddle =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      [ R.div
        [ RP.className "col-md-offset-5" ]
        (origRender dispatch p s c)
      ]

chooseButton :: forall eff. T.Spec eff State Props Action
chooseButton =
  wrapMiddle $ T.simpleSpec T.defaultPerformAction render
  where
    render :: T.Render State Props Action
    render dispatch _ _ _ =
      let
        buttonProps =
          { bsSize : "large"
          , onClick : dispatch ChooseDirectoryModal.ShowModal
          }
      in
       [ Button.button buttonProps
         [ R.div
           [ RP.className "col-md-2" ]
           [ Glyphicon.glyphicon' "book"
           , R.text " Choose books directory..."
           ]
         ]
       ]

spec :: forall eff. T.Spec (ajax :: AJAX, err :: EXCEPTION, pouchdb :: DB.POUCHDB | eff) State Props Action
spec =
  fold
  [ T.withState (\st ->
                  if not st.stateLoaded
                  then AjaxLoader.spec
                  else
                    case st.directory of
                      Nothing ->
                        chooseButton
                      Just _ ->
                        mapPropsWithState tryGetChoosedDirectoryProps $ maybeProps choosedDirectory
                )
  , T.simpleSpec performAction T.defaultRender
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focusState modalState ChooseDirectoryModal.spec
  ]
  where
    tryGetChoosedDirectoryProps p s = do
      dir <- s.directory
      db <- p.db
      return { onedriveToken: p.onedriveToken
             , directory: dir
             , db
             }

    tryGetChooseDirectoryModalProps p = do
      db <- p.db
      return { onedriveToken: p.onedriveToken
             , db
             }

    performAction (ChooseDirectoryModal.FileTreeAction action) props state update =
      processFileTreeAction action props state update
    performAction _ _ _ _ =
      pure unit

    processFileTreeAction action props state update =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          launchAff $ do
            (liftEff' $ update $ \s -> s { directory = Nothing, stateLoaded = false }) >>= guardEither
            dir <- getDirectoryInfo props.onedriveToken itemId
            (liftEff' $ update $ \s -> s { directory = Just dir, stateLoaded = true }) >>= guardEither
        _ ->
          pure unit

reactClass :: R.ReactClass Props
reactClass =
  R.createClass reactSpec.spec { componentDidMount = componentDidMount }
  where
    reactSpec =
      T.createReactSpec spec defaultState

    componentDidMount this = launchAff $ do
      props <- liftEff $ R.getProps this
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        settings <- MaybeT $ tryGetSettings db
        dir <- lift $ getDirectoryInfo props.onedriveToken $ getBooksDirectory settings
        liftEff $ R.transformState this (_ { directory = Just dir, stateLoaded = true })
      where
        getBooksDirectory (Settings s) = s.booksDirectory

booksDirectory :: Props -> R.ReactElement
booksDirectory props =
  R.createElement reactClass props []

getDirectoryInfo :: forall e. String -> Maybe String -> Aff (ajax :: AJAX | e) DirectoryInfo
getDirectoryInfo token itemId = do
  item <- getItem <$> getOneDriveItem token itemId
  let parentPath = fromMaybe "" (getPath <$> item.parentReference)
  return { itemId, path: parentPath ++ "/" ++ item.name }
  where
    getItem (OneDriveItem item) = item
    getPath (ItemReference reference) =
      let
        idx = S.indexOf ":" reference.path
      in
       maybe reference.path (\i -> S.drop (i + 1) reference.path) idx


Added AJAX request with answers and results

module Flag.App (Event, Country(..), init, foldp, view) where

import Control.Monad.Aff (Aff)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (length, uncons, head, take, drop)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Int (fromNumber)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

answers :: Int
answers = 4

type State = { all :: Countries, current :: Array String, correct :: Number, incorrect :: Number }
type Countries = Array Country
data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | ReceiveAnswer String | ReceiveAnswers (Array String)
newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    obj <- decodeJson json
    name <- obj .? "name"
    flag <- obj .? "flag"
    pure $ Country { name, flag }

init :: State
init = { all: [], current: [], correct: 0.0, incorrect: 0.0 }

decode ∷ ∀ r. { response :: Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX | e) (Tuple Countries (Array String))
fetch = get "/countries.json" >>= \xs -> case decode xs of
  Left _          -> pure $ Tuple [] []
  Right countries -> pure $ Tuple countries (randomise countries)

randomise :: Countries -> Array String
randomise xs = take answers $ _.name <<< unwrap <$> xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe "" (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1.0 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1.0 },
  effects: [ pure <<< Just <<< ReceiveAnswers $ randomise <<< drop 1 $ state.all ]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0.0, incorrect = 0.0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show correct
    div ! className "incorrect" $ text $ show incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0.0 -> div $ text "..."
    Nothing, _   -> do
      div ! className "percentage" $ text $ (show percentage) <> "%"
      div ! className "score" $ text $ "You scored " <> (show correct) <> " out of " <> (show total) <> "!"
      a #! onClick (const RequestCountries) $ text "Restart"
      where total = maybe 0 id <<< fromNumber $ (state.correct + state.incorrect)
            correct = maybe 0 id <<< fromNumber $ state.correct
            incorrect = maybe 0 id <<< fromNumber $ state.incorrect
            percentage = maybe 0 id <<< fromNumber $ (state.correct / (state.correct + state.incorrect)) * 100.0

module Flag.App (Event, Country(..), init, foldp, view) where

import Data.Array (length, uncons, head, take, drop)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Control.Monad.Aff (Aff)
import Network.HTTP.Affjax (AJAX, get)
import Prelude hiding (div)

answers :: Int
answers = 4

type State = { all :: Countries, current :: Array String, correct :: Int, incorrect :: Int }
type Countries = Array Country
data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | GuessCountry String
newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    obj <- decodeJson json
    name <- obj .? "name"
    flag <- obj .? "flag"
    pure $ Country { name, flag }

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

decode ∷ ∀ r. { response :: Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX | e) (Tuple Countries (Array String))
fetch = get "/countries.json" >>= \xs -> case decode xs of
  Left _          -> pure $ Tuple [] []
  Right countries -> pure $ Tuple countries (take answers $ _.name <<< unwrap <$> countries)

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (GuessCountry name) state = noEffects $ case (_ == name) <<< maybe "" (_.name <<< unwrap) $ head state.all of
  true -> state { all = drop 1 state.all, correct = state.correct + 1 }
  _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1 }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all) of
    Just { head } -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ GuessCountry name) $ text name
    Nothing       -> div $ text "..."


convert str

convert str

module Content.Render.Test (tests) where

import Prelude (Unit, ($), (==), (<>), (<<<), discard, map)
import Data.List (singleton, (:), List(..))
import Text.Markdown.SlamDown (SlamDown, SlamDownP(..), Block(..), Inline(..), CodeBlockType(..), ListType(..))
import Text.Smolder.HTML (div, p, pre, code, ol, ul, li, blockquote, h1, h3, a)
import Text.Smolder.HTML.Attributes (className, href)
import Text.Smolder.Markup (text, Markup, (!))
import Text.Smolder.Renderer.String as MR
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test, Test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert, equal)

import Content.Render (render)

para :: forall a. String -> Block a
para txt = Paragraph $ singleton $ Str txt

blockp :: forall a. String -> Block a
blockp = para

singletonMd :: forall a. Block a -> SlamDownP a
singletonMd = SlamDown <<< singleton

paragraphMd :: forall a. String -> SlamDownP a
paragraphMd = singletonMd <<< blockp

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Content.Render block elements" do
        test "convert paragraph" do
            let ptext = "such text!"
            let source = paragraphMd ptext
            let expected = div $ do
                             p $ text ptext
            check source expected
        test "convert multiple paragraphs" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown (blockp ptext1 : blockp ptext2 : Nil)
            let expected = div $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert multiple text" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let ptext3 = "with addition"
            let source = SlamDown (blockp ptext1 : Paragraph  (Str ptext2 : Str ptext3 : Nil) : Nil)
            let expected = div $ do
                  p $ text ptext1
                  p $ do
                    text ptext2
                    text ptext3
            check source expected
        test "convert fenced code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "") lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert fenced code block with language" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "cpp") lines
          let expected = div $ do
                pre $ code ! className "language-cpp" $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert indented code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock Indented lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert ordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Ordered "1.") (items1 : items2 : Nil)
          let expected = div $ do
                ol $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert unordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Bullet "*") (items1 : items2 : Nil)
          let expected = div $ do
                ul $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert block quote" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown $ singleton $ Blockquote (para ptext1 : para ptext2 : Nil)
            let expected = div $ blockquote $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert header" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 1 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h1 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert header level" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 3 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h3 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert link reference" do
            let label = "destination"
            let dest = "https://gregwiley.com"
            let source = SlamDown $ singleton $ LinkReference label dest
            let expected = div $ a ! href dest $ text label
            check source expected
    suite "Content.Render inline elements" do
        test "convert strt" do
            let ptext = "such text!"
            let source = Str ptext
            let expected = text ptext
            checkInline source expected

check :: forall e a. SlamDown -> Markup a -> Test (console :: CONSOLE | e)
check source expected = do
    let actual = render source
    equal (MR.render expected) (MR.render actual)

checkInline :: forall e a. Inline String -> Markup a -> Test (console :: CONSOLE | e)
checkInline source expected = do
    let embeddedSource = SlamDown $ singleton $ Paragraph $ singleton source
    let embeddedExpected = div $ p expected
    check embeddedSource embeddedExpected

module Content.Render.Test (tests) where

import Prelude (Unit, ($), (==), (<>), (<<<), discard, map)
import Data.List (singleton, (:), List(..))
import Text.Markdown.SlamDown (SlamDown, SlamDownP(..), Block(..), Inline(..), CodeBlockType(..), ListType(..))
import Text.Smolder.HTML (div, p, pre, code, ol, ul, li, blockquote, h1, h3, a)
import Text.Smolder.HTML.Attributes (className, href)
import Text.Smolder.Markup (text, Markup, (!))
import Text.Smolder.Renderer.String as MR
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test, Test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert, equal)

import Content.Render (render)

para :: forall a. String -> Block a
para txt = Paragraph $ singleton $ Str txt

blockp :: forall a. String -> Block a
blockp = para

singletonMd :: forall a. Block a -> SlamDownP a
singletonMd = SlamDown <<< singleton

paragraphMd :: forall a. String -> SlamDownP a
paragraphMd = singletonMd <<< blockp

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Content.Render" do
        test "convert paragraph" do
            let ptext = "such text!"
            let source = paragraphMd ptext
            let expected = div $ do
                             p $ text ptext
            check source expected
        test "convert multiple paragraphs" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown (blockp ptext1 : blockp ptext2 : Nil)
            let expected = div $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert multiple text" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let ptext3 = "with addition"
            let source = SlamDown (blockp ptext1 : Paragraph  (Str ptext2 : Str ptext3 : Nil) : Nil)
            let expected = div $ do
                  p $ text ptext1
                  p $ do
                    text ptext2
                    text ptext3
            check source expected
        test "convert fenced code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "") lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert fenced code block with language" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "cpp") lines
          let expected = div $ do
                pre $ code ! className "language-cpp" $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert indented code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock Indented lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert ordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Ordered "1.") (items1 : items2 : Nil)
          let expected = div $ do
                ol $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert unordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Bullet "*") (items1 : items2 : Nil)
          let expected = div $ do
                ul $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert block quote" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown $ singleton $ Blockquote (para ptext1 : para ptext2 : Nil)
            let expected = div $ blockquote $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert header" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 1 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h1 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert header level" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 3 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h3 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert link reference" do
            let label = "destination"
            let dest = "https://gregwiley.com"
            let source = SlamDown $ singleton $ LinkReference label dest
            let expected = div $ a ! href dest $ text label
            check source expected

check :: forall e a. SlamDown -> Markup a -> Test (console :: CONSOLE | e)
check source expected = do
    let actual = render source
    equal (MR.render expected) (MR.render actual)


Allow upper case letters in names

Allow upper case letters in names

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Data.Either
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)
import Control.Lazy        (fix1)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

parse :: forall a. Parser String a -> String -> Either String a
parse p s = case runParser s p of
  Left err -> Left $ show err
  Right a  -> Right a

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

num :: Parser String Atom
num = do
  str <- string "0" <|> nat
  return $ Num $ readInt 10 str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "False" *> return (Bool false)
  t = string "True" *> return (Bool true)

char_ :: Parser String Atom
char_ = Char <$> choice [ string "\\\\" *> return "\\"
--                        , string "\\n"  *> return "\n"
--                        , string "\\r"  *> return "\r"
--                        , string "\\t"  *> return "\t"
                        , string "\\\""  *> return "\""
                        , char
                        ]

character :: Parser String Atom
character = between (string "'") (string "'") char_

name :: Parser String String
name = do
  str <- joinWith "" <$> (some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'")
  if str == "if" || str == "then" || str == "else"
    then fail $ "Trying to match reserved keyword: " ++ str
    else return str

atom :: Parser String Atom
atom = do
  num <|> try bool <|> character <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

parseExpr :: String -> Either String Expr
parseExpr = parse (eatSpaces *> expr)

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string "," *> eatSpaces))
  eatSpaces
  string "]"
  return ls

stringList :: Parser String [Atom]
stringList = do
  string "\""
  char_ `manyTill` (string "\"")

app :: Parser String Expr -> Parser String Expr
app expr = do
  func <- expr
  exprs <- some (try $ eatSpaces *> expr)
  return $ App func exprs

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = bracket (try sectR <|> sectL)
  where
  sectR = do
    op <- choice opList
    eatSpaces
    e <- expr
    return $ SectR op e
  sectL = do
    e <- expr
    eatSpaces
    op <- choice opList
    return $ SectL e op

opList :: [Parser String Op]
opList =
  [ opP (string ".")     Composition
  , opP (string "^")     Power
  , opP (string "*")     Mul
  , opP (try $ string "`div`") Div
  , opP (string "`mod`") Mod
  , opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "==")    Eq
  , opP (string "/=")    Neq
  , opP (string "<=")    Leq
  , opP (string "<")     Lt
  , opP (string ">=")    Geq
  , opP (string ">")     Gt
  , opP (string "&&")    And
  , opP (string "||")    Or
  , opP (string "$")     Dollar
  ]

prefixOp :: Parser String Expr
prefixOp = bracket $ Prefix <$> choice opList

sepBy2 :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
sepBy2 p sep = do
  a <- p
  as <- some $ do
    sep
    p
  return (a:as)

tuple :: forall a. Parser String a -> Parser String [a]
tuple expr = bracket $ expr `sepBy2` (try (eatSpaces *> string "," *> eatSpaces))

base :: Parser String Expr -> Parser String Expr
base expr =  (List <$> list expr)
         <|> ((List <<< (Atom <$>)) <$> stringList)
         <|> bracket expr
         <|> (Atom <$> atom)

lambda :: Parser String Expr -> Parser String Expr
lambda expr = bracket $ do
  string "\\"
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "->"
  eatSpaces
  body <- expr
  return $ Lambda binds body

ifthenelse :: Parser String Expr -> Parser String Expr
ifthenelse expr = do
  string "if" *> eatSpaces
  condition <- expr
  eatSpaces *> string "then" *> eatSpaces
  thenPart <- expr
  eatSpaces *> string "else" *> eatSpaces
  elsePart <- expr
  return $ IfExpr condition thenPart elsePart

termNTuple :: Parser String Expr -> Parser String Expr
termNTuple expr = try (NTuple <$> tuple expr) <|> base expr

termLambda :: Parser String Expr -> Parser String Expr
termLambda expr = try (lambda expr) <|> termNTuple expr

termPrefixOp :: Parser String Expr -> Parser String Expr
termPrefixOp expr = try prefixOp <|> termLambda expr

termSect :: Parser String Expr -> Parser String Expr
termSect expr = try (section (termPrefixOp expr)) <|> termPrefixOp expr

termIf :: Parser String Expr -> Parser String Expr
termIf expr = try (ifthenelse expr) <|> termSect expr

termApp :: Parser String Expr -> Parser String Expr
termApp expr = try (app (termIf expr)) <|> termIf expr

opP :: forall a. Parser String a -> Op -> Parser String Op
opP strP opConstructor = try $
  (eatSpaces *> strP *> eatSpaces *> return opConstructor)

term9r :: Parser String Expr -> Parser String Expr
term9r expr = chainr1 (termApp expr) (Binary <$> opP (string ".") Composition)

term8r :: Parser String Expr -> Parser String Expr
term8r expr = chainr1 (term9r expr) (Binary <$> opP (string "^") Power)

term7l :: Parser String Expr -> Parser String Expr
term7l expr = chainl1 (term8r expr) (mulP <|> try divP <|> modP)
  where
  mulP = Binary <$> opP (string "*") Mul
  divP = Binary <$> opP (string "`div`") Div
  modP = Binary <$> opP (string "`mod`") Mod

term6neg :: Parser String Expr -> Parser String Expr
term6neg expr = try negation <|> (term7l expr)
  where
  negation = do
    string "-"
    eatSpaces
    e <- (term7l expr)
    return $ Unary Sub e

term6l :: Parser String Expr -> Parser String Expr
term6l expr = chainl1 (term6neg expr) (addP <|> subP)
  where
  addP = Binary <$> opP (string "+" *> notFollowedBy (string "+")) Add
  subP = Binary <$> opP (string "-") Sub

term5r :: Parser String Expr -> Parser String Expr
term5r expr = chainr1 (term6l expr) (consP <|> appendP)
  where
  consP = Binary <$> opP (string ":") Cons
  appendP = Binary <$> opP (string "++") Append

term4 :: Parser String Expr -> Parser String Expr
term4 expr = try comparison <|> term5r expr
  where
  comparison = do
    e1 <- term5r expr
    op <- choice [eq, neq, leq, lt, geq, gt]
    e2 <- term5r expr
    return $ Binary op e1 e2
  eq  = opP (string "==") Eq
  neq = opP (string "/=") Neq
  leq = opP (string "<=") Leq
  lt  = opP (string "<")  Lt
  geq = opP (string ">=") Geq
  gt  = opP (string ">")  Gt

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term4 expr) (Binary <$> opP (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (Binary <$> opP (string "||") Or)

term0r :: Parser String Expr -> Parser String Expr
term0r expr = chainr1 (term2r expr) (Binary <$> opP (string "$") Dollar)

expr :: Parser String Expr
expr = fix1 $ \expr -> term0r expr

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

tupleLit :: Parser String Binding -> Parser String Binding
tupleLit binding = NTupleLit <$> tuple binding

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> try (consLit binding) <|> tupleLit binding <|> listLit binding

---------------------------------------
-- Parsers for the 'Definition' type
---------------------------------------

parseDefs :: String -> Either String [Definition]
parseDefs = parse (skipSpaces *> defs)

def :: Parser String Definition
def = do
  defName <- name
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "="
  eatSpaces
  body <- expr
  return $ Def defName binds body

defs :: Parser String [Definition]
defs = def `sepEndBy` skipSpaces

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Data.Either
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)
import Control.Lazy        (fix1)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

parse :: forall a. Parser String a -> String -> Either String a
parse p s = case runParser s p of
  Left err -> Left $ show err
  Right a  -> Right a

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

num :: Parser String Atom
num = do
  str <- string "0" <|> nat
  return $ Num $ readInt 10 str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "False" *> return (Bool false)
  t = string "True" *> return (Bool true)

char_ :: Parser String Atom
char_ = Char <$> choice [ string "\\\\" *> return "\\"
--                        , string "\\n"  *> return "\n"
--                        , string "\\r"  *> return "\r"
--                        , string "\\t"  *> return "\t"
                        , string "\\\""  *> return "\""
                        , char
                        ]

character :: Parser String Atom
character = between (string "'") (string "'") char_

name :: Parser String String
name = do
  str <- joinWith "" <$> (some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'")
  if str == "if" || str == "then" || str == "else"
    then fail $ "Trying to match reserved keyword: " ++ str
    else return str

atom :: Parser String Atom
atom = do
  num <|> try bool <|> character <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

parseExpr :: String -> Either String Expr
parseExpr = parse (eatSpaces *> expr)

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string "," *> eatSpaces))
  eatSpaces
  string "]"
  return ls

stringList :: Parser String [Atom]
stringList = do
  string "\""
  char_ `manyTill` (string "\"")

app :: Parser String Expr -> Parser String Expr
app expr = do
  func <- expr
  exprs <- some (try $ eatSpaces *> expr)
  return $ App func exprs

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = bracket (try sectR <|> sectL)
  where
  sectR = do
    op <- choice opList
    eatSpaces
    e <- expr
    return $ SectR op e
  sectL = do
    e <- expr
    eatSpaces
    op <- choice opList
    return $ SectL e op

opList :: [Parser String Op]
opList =
  [ opP (string ".")     Composition
  , opP (string "^")     Power
  , opP (string "*")     Mul
  , opP (try $ string "`div`") Div
  , opP (string "`mod`") Mod
  , opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "==")    Eq
  , opP (string "/=")    Neq
  , opP (string "<=")    Leq
  , opP (string "<")     Lt
  , opP (string ">=")    Geq
  , opP (string ">")     Gt
  , opP (string "&&")    And
  , opP (string "||")    Or
  , opP (string "$")     Dollar
  ]

prefixOp :: Parser String Expr
prefixOp = bracket $ Prefix <$> choice opList

sepBy2 :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
sepBy2 p sep = do
  a <- p
  as <- some $ do
    sep
    p
  return (a:as)

tuple :: forall a. Parser String a -> Parser String [a]
tuple expr = bracket $ expr `sepBy2` (try (eatSpaces *> string "," *> eatSpaces))

base :: Parser String Expr -> Parser String Expr
base expr =  (List <$> list expr)
         <|> ((List <<< (Atom <$>)) <$> stringList)
         <|> bracket expr
         <|> (Atom <$> atom)

lambda :: Parser String Expr -> Parser String Expr
lambda expr = bracket $ do
  string "\\"
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "->"
  eatSpaces
  body <- expr
  return $ Lambda binds body

ifthenelse :: Parser String Expr -> Parser String Expr
ifthenelse expr = do
  string "if" *> eatSpaces
  condition <- expr
  eatSpaces *> string "then" *> eatSpaces
  thenPart <- expr
  eatSpaces *> string "else" *> eatSpaces
  elsePart <- expr
  return $ IfExpr condition thenPart elsePart

termNTuple :: Parser String Expr -> Parser String Expr
termNTuple expr = try (NTuple <$> tuple expr) <|> base expr

termLambda :: Parser String Expr -> Parser String Expr
termLambda expr = try (lambda expr) <|> termNTuple expr

termPrefixOp :: Parser String Expr -> Parser String Expr
termPrefixOp expr = try prefixOp <|> termLambda expr

termSect :: Parser String Expr -> Parser String Expr
termSect expr = try (section (termPrefixOp expr)) <|> termPrefixOp expr

termIf :: Parser String Expr -> Parser String Expr
termIf expr = try (ifthenelse expr) <|> termSect expr

termApp :: Parser String Expr -> Parser String Expr
termApp expr = try (app (termIf expr)) <|> termIf expr

opP :: forall a. Parser String a -> Op -> Parser String Op
opP strP opConstructor = try $
  (eatSpaces *> strP *> eatSpaces *> return opConstructor)

term9r :: Parser String Expr -> Parser String Expr
term9r expr = chainr1 (termApp expr) (Binary <$> opP (string ".") Composition)

term8r :: Parser String Expr -> Parser String Expr
term8r expr = chainr1 (term9r expr) (Binary <$> opP (string "^") Power)

term7l :: Parser String Expr -> Parser String Expr
term7l expr = chainl1 (term8r expr) (mulP <|> try divP <|> modP)
  where
  mulP = Binary <$> opP (string "*") Mul
  divP = Binary <$> opP (string "`div`") Div
  modP = Binary <$> opP (string "`mod`") Mod

term6neg :: Parser String Expr -> Parser String Expr
term6neg expr = try negation <|> (term7l expr)
  where
  negation = do
    string "-"
    eatSpaces
    e <- (term7l expr)
    return $ Unary Sub e

term6l :: Parser String Expr -> Parser String Expr
term6l expr = chainl1 (term6neg expr) (addP <|> subP)
  where
  addP = Binary <$> opP (string "+" *> notFollowedBy (string "+")) Add
  subP = Binary <$> opP (string "-") Sub

term5r :: Parser String Expr -> Parser String Expr
term5r expr = chainr1 (term6l expr) (consP <|> appendP)
  where
  consP = Binary <$> opP (string ":") Cons
  appendP = Binary <$> opP (string "++") Append

term4 :: Parser String Expr -> Parser String Expr
term4 expr = try comparison <|> term5r expr
  where
  comparison = do
    e1 <- term5r expr
    op <- choice [eq, neq, leq, lt, geq, gt]
    e2 <- term5r expr
    return $ Binary op e1 e2
  eq  = opP (string "==") Eq
  neq = opP (string "/=") Neq
  leq = opP (string "<=") Leq
  lt  = opP (string "<")  Lt
  geq = opP (string ">=") Geq
  gt  = opP (string ">")  Gt

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term4 expr) (Binary <$> opP (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (Binary <$> opP (string "||") Or)

term0r :: Parser String Expr -> Parser String Expr
term0r expr = chainr1 (term2r expr) (Binary <$> opP (string "$") Dollar)

expr :: Parser String Expr
expr = fix1 $ \expr -> term0r expr

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

tupleLit :: Parser String Binding -> Parser String Binding
tupleLit binding = NTupleLit <$> tuple binding

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> try (consLit binding) <|> tupleLit binding <|> listLit binding

---------------------------------------
-- Parsers for the 'Definition' type
---------------------------------------

parseDefs :: String -> Either String [Definition]
parseDefs = parse (skipSpaces *> defs)

def :: Parser String Definition
def = do
  defName <- name
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "="
  eatSpaces
  body <- expr
  return $ Def defName binds body

defs :: Parser String [Definition]
defs = def `sepEndBy` skipSpaces