#1585 found what was up with that test failing, mevent checking here

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Dialog.Component
  ( Query(..)
  , Message(..)
  , ChildSlot
  , component
  , module SlamData.Workspace.Dialog.Types
  ) where

import SlamData.Prelude

import DOM.Event.Types (MouseEvent)

import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

import Quasar.Advanced.Types as QAT

import SlamData.Dialog.Error.Component as Error
import SlamData.License as License
import SlamData.Workspace.Dialog.Confirm.Component as Confirm
import SlamData.Workspace.Dialog.Export.Component as Export
import SlamData.Workspace.Dialog.Reason.Component as Reason
import SlamData.Workspace.Dialog.Rename.Component as Rename
import SlamData.Workspace.Dialog.Share.Component as Share
import SlamData.Workspace.Dialog.Unshare.Component as Unshare
import SlamData.Dialog.License (advancedLicenseExpired, advancedTrialLicenseExpired, licenseInvalid)
import SlamData.Monad (Slam)
import SlamData.Render.ClassName as CN
import SlamData.Workspace.Deck.Options (DeckOptions)
import SlamData.Workspace.Dialog.Types (Dialog(..))

import Utils.DOM as DOM

type State = Maybe Dialog

data Query a
  = Show Dialog a
  | Raise Message a
  | BackdropDismiss MouseEvent a

data Message
  = Dismissed
  | Confirm DeckOptions Dialog Boolean

type ChildQuery =
  Rename.Query
  ⨁ Error.Query
  ⨁ Confirm.Query
  ⨁ Export.Query
  ⨁ Export.Query
  ⨁ Share.Query
  ⨁ Unshare.Query
  ⨁ Reason.Query
  ⨁ Const Void

type ChildSlot =
  Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Void

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam

type DSL = H.ParentDSL State Query ChildQuery ChildSlot Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.parentComponent
    { render
    , eval
    , initialState: const Nothing
    , receiver: const Nothing
    }

renderDialogContainer ∷ Array HTML → HTML
renderDialogContainer =
  HH.div
    [ HP.class_ CN.dialogContainer
    , HE.onClick $ HE.input BackdropDismiss
    ]

render ∷ State → HTML
render = case _ of
  Nothing →
    HH.text ""
  Just (LicenseProblem problem) →
    renderDialogContainer [ dialog $ LicenseProblem problem ]
  Just s →
    renderDialogContainer
      [ HH.div [ HP.class_ CN.dialog ] [ dialog s ] ]
  where
  dialog dlg = case dlg of
    Rename opts name →
      HH.slot' CP.cp1 unit Rename.component name
        case _ of
          Rename.Dismiss → Just $ H.action $ Raise Dismissed
          Rename.Rename name' → Just $ H.action $ Raise (Confirm opts (Rename opts name') true)

    Error _ str →
      HH.slot' CP.cp2 unit Error.nonModalComponent str
        \Error.Dismiss → Just $ H.action $ Raise Dismissed

    DeleteDeck opts →
      HH.slot' CP.cp3 unit Confirm.component
        { title: "Delete deck"
        , body: "Are you sure you want to delete this deck?"
        , cancel: "Cancel"
        , confirm: "Delete"
        }
        \(Confirm.Confirm bool) → Just $ H.action $ Raise (Confirm opts dlg bool)

    Embed _ sharingInput varMaps →
      HH.slot' CP.cp4 unit Export.component
        { sharingInput
        , presentingAs: Export.Embed
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Publish _ sharingInput varMaps →
      HH.slot' CP.cp5 unit Export.component
        { sharingInput
        , presentingAs: Export.Publish
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Share _ sharingInput →
      HH.slot' CP.cp6 unit Share.component sharingInput
        \Share.Dismiss → Just $ H.action $ Raise Dismissed

    Unshare _ sharingInput →
      HH.slot' CP.cp7 unit Unshare.component sharingInput
        \Unshare.Dismiss → Just $ H.action $ Raise Dismissed

    Reason _ attemptedCardType reason cardPaths →
      HH.slot' CP.cp8 unit Reason.component
        { attemptedCardType
        , reason
        , cardPaths
        }
        \Reason.Dismiss → Just $ H.action $ Raise Dismissed

    LicenseProblem (License.Expired licenseType) →
      case licenseType of
        QAT.Advanced → advancedLicenseExpired
        QAT.AdvancedTrial → advancedTrialLicenseExpired

    LicenseProblem License.Invalid →
      licenseInvalid

eval ∷ Query ~> DSL
eval = case _ of
  Show dialog next → H.put (Just dialog) $> next
  Raise msg next → H.put Nothing *> H.raise msg $> next
  BackdropDismiss me next → do
    isDialog ← H.liftEff $ DOM.nodeEq (DOM.target me) (DOM.currentTarget me)
    when isDialog do
      H.put Nothing
    pure next

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Dialog.Component
  ( Query(..)
  , Message(..)
  , ChildSlot
  , component
  , module SlamData.Workspace.Dialog.Types
  ) where

import SlamData.Prelude

import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

import Quasar.Advanced.Types as QAT

import SlamData.Dialog.Error.Component as Error
import SlamData.License as License
import SlamData.Workspace.Dialog.Confirm.Component as Confirm
import SlamData.Workspace.Dialog.Export.Component as Export
import SlamData.Workspace.Dialog.Reason.Component as Reason
import SlamData.Workspace.Dialog.Rename.Component as Rename
import SlamData.Workspace.Dialog.Share.Component as Share
import SlamData.Workspace.Dialog.Unshare.Component as Unshare
import SlamData.Dialog.License (advancedLicenseExpired, advancedTrialLicenseExpired, licenseInvalid)
import SlamData.Monad (Slam)
import SlamData.Render.ClassName as CN
import SlamData.Workspace.Deck.Options (DeckOptions)
import SlamData.Workspace.Dialog.Types (Dialog(..))

type State = Maybe Dialog

data Query a
  = Show Dialog a
  | Raise Message a

data Message
  = Dismissed
  | Confirm DeckOptions Dialog Boolean

type ChildQuery =
  Rename.Query
  ⨁ Error.Query
  ⨁ Confirm.Query
  ⨁ Export.Query
  ⨁ Export.Query
  ⨁ Share.Query
  ⨁ Unshare.Query
  ⨁ Reason.Query
  ⨁ Const Void

type ChildSlot =
  Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Void

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam

type DSL = H.ParentDSL State Query ChildQuery ChildSlot Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.parentComponent
    { render
    , eval
    , initialState: const Nothing
    , receiver: const Nothing
    }

renderDialogContainer ∷ Array HTML → HTML
renderDialogContainer =
  HH.div
    [ HP.classes [ CN.dialogContainer ]
    , HE.onClick $ HE.input_ $ Raise Dismissed
    ]

render ∷ State → HTML
render = case _ of
  Nothing →
    HH.text ""
  Just (LicenseProblem problem) →
    renderDialogContainer [ dialog $ LicenseProblem problem ]
  Just s →
    renderDialogContainer
      [ HH.div [ HP.class_ CN.dialog ] [ dialog s ] ]
  where
  dialog dlg = case dlg of
    Rename opts name →
      HH.slot' CP.cp1 unit Rename.component name
        case _ of
          Rename.Dismiss → Just $ H.action $ Raise Dismissed
          Rename.Rename name' → Just $ H.action $ Raise (Confirm opts (Rename opts name') true)

    Error _ str →
      HH.slot' CP.cp2 unit Error.nonModalComponent str
        \Error.Dismiss → Just $ H.action $ Raise Dismissed

    DeleteDeck opts →
      HH.slot' CP.cp3 unit Confirm.component
        { title: "Delete deck"
        , body: "Are you sure you want to delete this deck?"
        , cancel: "Cancel"
        , confirm: "Delete"
        }
        \(Confirm.Confirm bool) → Just $ H.action $ Raise (Confirm opts dlg bool)

    Embed _ sharingInput varMaps →
      HH.slot' CP.cp4 unit Export.component
        { sharingInput
        , presentingAs: Export.Embed
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Publish _ sharingInput varMaps →
      HH.slot' CP.cp5 unit Export.component
        { sharingInput
        , presentingAs: Export.Publish
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Share _ sharingInput →
      HH.slot' CP.cp6 unit Share.component sharingInput
        \Share.Dismiss → Just $ H.action $ Raise Dismissed

    Unshare _ sharingInput →
      HH.slot' CP.cp7 unit Unshare.component sharingInput
        \Unshare.Dismiss → Just $ H.action $ Raise Dismissed

    Reason _ attemptedCardType reason cardPaths →
      HH.slot' CP.cp8 unit Reason.component
        { attemptedCardType
        , reason
        , cardPaths
        }
        \Reason.Dismiss → Just $ H.action $ Raise Dismissed

    LicenseProblem (License.Expired licenseType) →
      case licenseType of
        QAT.Advanced → advancedLicenseExpired
        QAT.AdvancedTrial → advancedTrialLicenseExpired

    LicenseProblem License.Invalid →
      licenseInvalid

eval ∷ Query ~> DSL
eval = case _ of
  Show dialog next → H.put (Just dialog) $> next
  Raise msg next → H.put Nothing *> H.raise msg $> next


fix schema validation: array[number] : number

module Ifrit.Semantic
  ( Schema(..)
  , analyze
  , fromJson
  , fromString
  ) where

import Prelude

import Data.Argonaut.Core(Json, foldJson, stringify)
import Data.Argonaut.Decode(class DecodeJson, decodeJson)
import Data.Argonaut.Encode(class EncodeJson, encodeJson)
import Data.Argonaut.Parser(jsonParser)
import Data.Array(head, length)
import Data.Either(Either(..))
import Data.List as List
import Data.Maybe(Maybe(..), maybe)
import Data.StrMap as StrMap
import Data.StrMap(StrMap)
import Data.String(Pattern(..), split)
import Data.Traversable(traverse)
import Partial.Unsafe(unsafePartial)

import Ifrit.Parser as Parser
import Ifrit.Lexer as Lexer

data Schema
  = Object (StrMap Schema)
  | Array Schema
  | String
  | Number
  | Boolean
  | Null

fromString :: String -> Either String Schema
fromString =
  jsonParser >=> fromJson

fromJson :: Json -> Either String Schema
fromJson =
  decodeJson

lookupProjection :: Schema -> StrMap Schema -> Parser.Projection -> Either String (StrMap Schema)
lookupProjection schema acc (Parser.Projection selector) =
  let
      lookupNumberProjection :: Partial => StrMap Schema -> Parser.Selector -> Either String (StrMap Schema)
      lookupNumberProjection source (Parser.Function f key as) =
        case split (Pattern ".") key of
          [_] ->
            case StrMap.lookup key source of
              Just (Array Number) ->
                Right $ StrMap.insert (maybe key (\x -> x) as) Number acc
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "' applied to non array<number>"
              Nothing ->
                Left $ "unexisting field: '" <> key <> "'"

          [base, key'] ->
            case StrMap.lookup base source of
              Just (Array (Object source')) ->
                case StrMap.lookup key' source' of
                  Just Number ->
                    Right $ StrMap.insert (maybe key' (\x -> x) as) Number acc
                  Just _ ->
                    Left $ "invalid operation: function '" <> show f <> "' applied to non number"
                  Nothing ->
                    Left $ "unexisting field: '" <> key <> "'"
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "': target isn't array<object>"

          _ ->
            Left $ "invalid field's name: '" <> key <> "'"
  in
      case { schema, selector } of
        { schema: Object source, selector: Parser.Selector key as } ->
          case StrMap.lookup key source of
            Just schema' ->
              Right $ StrMap.insert (maybe key (\x -> x) as) schema' acc

            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"

        { schema: Object source, selector: f@(Parser.Function Lexer.Avg key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Count key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Max key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Min key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Sum key as) } ->
          unsafePartial $ lookupNumberProjection source f

        _ ->
          Left "invalid operation: can't SELECT on non object"

lookupAggregation :: Schema -> StrMap Schema -> Parser.Aggregation -> Either String (StrMap Schema)
lookupAggregation schema acc (Parser.Aggregation selector) =
  let
      lookupNumberAggregation :: Partial => StrMap Schema -> Parser.Selector -> Either String (StrMap Schema)
      lookupNumberAggregation source (Parser.Function f key as) =
        case split (Pattern ".") key of
          [_] ->
            case StrMap.lookup key source of
              Just Number ->
                Right $ StrMap.insert (maybe key (\x -> x) as) Number acc
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "' applied to non number"
              Nothing ->
                Left $ "unexisting field: '" <> key <> "'"

          _ ->
            Left $ "invalid field's name: '" <> key <> "'"
  in
      case { schema, selector } of
        { selector: Parser.Selector "_id" Nothing } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Selector _ (Just "_id") } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Function _ "_id" Nothing } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Function _ _ (Just "_id") } ->
          Left $ "reserved field's name: _id"

        { schema: Object source, selector: Parser.Selector key as } ->
          case StrMap.lookup key source of
            Just schema' ->
              Right $ StrMap.insert (maybe key (\x -> x) as) (Array schema') acc

            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"

        { schema: Object source, selector: f@(Parser.Function Lexer.Avg key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Count key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Max key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Min key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Sum key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        _ ->
          Left "invalid operation: can't SELECT on non object"

analyze :: Schema -> Parser.Statement -> Either String Schema
analyze schema (Parser.Select projections statement condition) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  schema'' <- List.foldM (lookupProjection schema') StrMap.empty projections
  pure $ Object schema''

analyze schema (Parser.Group index aggregations statement condition) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  schema'' <- List.foldM (lookupAggregation schema') StrMap.empty aggregations
  case index of
    Parser.IdxNull ->
      pure $ Object $ StrMap.insert "_id" Null schema''
    Parser.IdxField key ->
      case schema' of
        Object source ->
          case StrMap.lookup key source of
            Just schemaIndex ->
              pure $ Object $ StrMap.insert "_id" schemaIndex schema''
            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"
        _ ->
          Left "invalid operation: can't SELECT on non object"

instance decodeSchema :: DecodeJson Schema where
  decodeJson =
    let
        decodeNull _ =
          Left "can't decode null to schema"
        decodeBoolean _ =
          Left "can't decode boolean to schema"
        decodeNumber _ =
          Left "can't decode number to schema"
        decodeString "string" =
          Right String
        decodeString "number" =
          Right Number
        decodeString "boolean" =
          Right Boolean
        decodeString "null" =
          Right Null
        decodeString s =
          Left ("can't decode type: invalid provided type: " <> s)
        decodeArray xs =
          if length xs /= 1
             then Left "can't decode array: exactly one element is expected"
             else case head xs of
               Nothing ->
                Left "can't decode array: exactly one element is expected"
               Just schema ->
                 Array <$> decodeJson schema
        decodeObject obj = Object <$> traverse decodeJson obj
    in
        foldJson decodeNull decodeBoolean decodeNumber decodeString decodeArray decodeObject

instance encodeJsonSchema :: EncodeJson Schema where
  encodeJson (Object schema) =
    encodeJson $ map encodeJson schema
  encodeJson (Array schema) =
    encodeJson [encodeJson schema]
  encodeJson Number =
    encodeJson "number"
  encodeJson String =
    encodeJson "string"
  encodeJson Boolean =
    encodeJson "boolean"
  encodeJson Null =
    encodeJson "null"

instance showSchema :: EncodeJson Schema => Show Schema where
  show = encodeJson >>> stringify

module Ifrit.Semantic
  ( Schema(..)
  , analyze
  , fromJson
  ) where

import Prelude

import Data.Argonaut.Core(foldJson, stringify)
import Data.Argonaut.Decode(class DecodeJson, decodeJson)
import Data.Argonaut.Encode(class EncodeJson, encodeJson)
import Data.Argonaut.Parser(jsonParser)
import Data.Array(head, length)
import Data.Either(Either(..))
import Data.List as List
import Data.Maybe(Maybe(..), maybe)
import Data.StrMap as StrMap
import Data.StrMap(StrMap)
import Data.String(Pattern(..), split)
import Data.Traversable(traverse)
import Partial.Unsafe(unsafePartial)

import Ifrit.Parser as Parser
import Ifrit.Lexer as Lexer

data Schema
  = Object (StrMap Schema)
  | Array Schema
  | String
  | Number
  | Boolean
  | Null

fromJson :: String -> Either String Schema
fromJson =
  jsonParser >=> decodeJson

lookupProjection :: Schema -> StrMap Schema -> Parser.Projection -> Either String (StrMap Schema)
lookupProjection schema acc (Parser.Projection selector) =
  let
      lookupNumberProjection :: Partial => StrMap Schema -> Parser.Selector -> Either String (StrMap Schema)
      lookupNumberProjection source (Parser.Function f key as) =
        case split (Pattern ".") key of
          [_] ->
            case StrMap.lookup key source of
              Just (Array Number) ->
                Right $ StrMap.insert (maybe key (\x -> x) as) Number acc
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "' applied to non array<number>"
              Nothing ->
                Left $ "unexisting field: '" <> key <> "'"

          [base, key'] ->
            case StrMap.lookup base source of
              Just (Array (Object source')) ->
                case StrMap.lookup key' source' of
                  Just Number ->
                    Right $ StrMap.insert (maybe key' (\x -> x) as) Number acc
                  Just _ ->
                    Left $ "invalid operation: function '" <> show f <> "' applied to non number"
                  Nothing ->
                    Left $ "unexisting field: '" <> key <> "'"
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "': target isn't array<object>"

          _ ->
            Left $ "invalid field's name: '" <> key <> "'"
  in
      case { schema, selector } of
        { schema: Object source, selector: Parser.Selector key as } ->
          case StrMap.lookup key source of
            Just schema' ->
              Right $ StrMap.insert (maybe key (\x -> x) as) schema' acc

            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"

        { schema: Object source, selector: f@(Parser.Function Lexer.Avg key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Count key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Max key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Min key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Sum key as) } ->
          unsafePartial $ lookupNumberProjection source f

        _ ->
          Left "invalid operation: can't SELECT on non object"

lookupAggregation :: Schema -> StrMap Schema -> Parser.Aggregation -> Either String (StrMap Schema)
lookupAggregation schema acc (Parser.Aggregation selector) =
  let
      lookupNumberAggregation :: Partial => StrMap Schema -> Parser.Selector -> Either String (StrMap Schema)
      lookupNumberAggregation source (Parser.Function f key as) =
        case split (Pattern ".") key of
          [_] ->
            case StrMap.lookup key source of
              Just (Array Number) ->
                Right $ StrMap.insert (maybe key (\x -> x) as) Number acc
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "' applied to non array<number>"
              Nothing ->
                Left $ "unexisting field: '" <> key <> "'"

          _ ->
            Left $ "invalid field's name: '" <> key <> "'"
  in
      case { schema, selector } of
        { selector: Parser.Selector "_id" Nothing } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Selector _ (Just "_id") } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Function _ "_id" Nothing } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Function _ _ (Just "_id") } ->
          Left $ "reserved field's name: _id"

        { schema: Object source, selector: Parser.Selector key as } ->
          case StrMap.lookup key source of
            Just schema' ->
              Right $ StrMap.insert (maybe key (\x -> x) as) (Array schema') acc

            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"

        { schema: Object source, selector: f@(Parser.Function Lexer.Avg key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Count key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Max key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Min key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Sum key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        _ ->
          Left "invalid operation: can't SELECT on non object"

analyze :: Schema -> Parser.Statement -> Either String Schema
analyze schema (Parser.Select projections statement condition) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  schema'' <- List.foldM (lookupProjection schema') StrMap.empty projections
  pure $ Object schema''

analyze schema (Parser.Group index aggregations statement condition) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  schema'' <- List.foldM (lookupAggregation schema') StrMap.empty aggregations
  case index of
    Parser.IdxNull ->
      pure $ Object $ StrMap.insert "_id" Null schema''
    Parser.IdxField key ->
      case schema' of
        Object source ->
          case StrMap.lookup key source of
            Just schemaIndex ->
              pure $ Object $ StrMap.insert "_id" schemaIndex schema''
            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"
        _ ->
          Left "invalid operation: can't SELECT on non object"

instance decodeSchema :: DecodeJson Schema where
  decodeJson =
    let
        decodeNull _ =
          Left "can't decode null to schema"
        decodeBoolean _ =
          Left "can't decode boolean to schema"
        decodeNumber _ =
          Left "can't decode number to schema"
        decodeString "string" =
          Right String
        decodeString "number" =
          Right Number
        decodeString "boolean" =
          Right Boolean
        decodeString "null" =
          Right Null
        decodeString s =
          Left ("can't decode type: invalid provided type: " <> s)
        decodeArray xs =
          if length xs /= 1
             then Left "can't decode array: exactly one element is expected"
             else case head xs of
               Nothing ->
                Left "can't decode array: exactly one element is expected"
               Just schema ->
                 Array <$> decodeJson schema
        decodeObject obj = Object <$> traverse decodeJson obj
    in
        foldJson decodeNull decodeBoolean decodeNumber decodeString decodeArray decodeObject

instance encodeJsonSchema :: EncodeJson Schema where
  encodeJson (Object schema) =
    encodeJson $ map encodeJson schema
  encodeJson (Array schema) =
    encodeJson [encodeJson schema]
  encodeJson Number =
    encodeJson "number"
  encodeJson String =
    encodeJson "string"
  encodeJson Boolean =
    encodeJson "boolean"
  encodeJson Null =
    encodeJson "null"

instance showSchema :: EncodeJson Schema => Show Schema where
  show = encodeJson >>> stringify


Refactoring...

Refactoring...

module Main where

import Debug.Trace
import Control.Monad.State
import Control.Monad.State.Class

-- Import the library's module(s)
import Gattaca.Experiments.Rx
import Gattaca.Experiments.Utils

-- Import Test.QuickCheck, which supports property-based testing
import Test.QuickCheck

-- Main.main is the entry point of the application
--
-- In the case of the test suite, Main.main will use QuickCheck to test a collection
-- of properties that we expect of the diffs function.

toList :: forall a.Observable (State [a]) a -> [a]
toList os = execState (os |> subscribe (\x -> modify (\xs -> xs ++ [x])) (\unit -> return unit)) []

testObservable :: forall a.(Observable (State [a]) a -> Observable (State [a]) a) -> [a] -> [a]
testObservable f =  toObservable >>> f >>> toList

main = do
          trace "Applicative laws:"
          trace "Identity"
          quickCheck $ \ns -> let xs = ns :: [Number] in
                              testObservable (\v -> pure id <*> v) xs == xs
          trace "Composition"
          quickCheck $ \ns -> let u = toObservable [\x -> x * x, \x -> x + 5] :: Observable (State [Number]) (Number -> Number)
                                  v = toObservable [\x -> x * x * x, \x -> x / 2, \x -> x ^ 2] :: Observable (State [Number]) (Number -> Number)
                                  w = toObservable ns :: Observable (State [Number]) Number
                                  xs = (pure (<<<)) <*> u <*> v <*> w :: Observable (State [(Number)]) Number
                                  ys = u <*> (v <*> w) :: Observable (State [(Number)]) (Number)
                             in  toList xs == toList ys

module Main where

import Debug.Trace
import Control.Monad.State
import Control.Monad.State.Class

-- Import the library's module(s)
import Gattaca.Experiments.Rx
import Gattaca.Experiments.Utils

-- Import Test.QuickCheck, which supports property-based testing
import Test.QuickCheck

-- Main.main is the entry point of the application
--
-- In the case of the test suite, Main.main will use QuickCheck to test a collection
-- of properties that we expect of the diffs function.

toList :: forall a.Observable (State [a]) a -> [a]
toList os = execState (os |> subscribe (\x -> modify (\xs -> xs ++ [x])) (\unit -> return unit)) []

testObservable :: forall a.(Observable (State [a]) a -> Observable (State [a]) a) -> [a] -> [a]
testObservable f =  toObservable >>> f >>> toList

main = do
          trace "Applicative laws:"
          trace "Identity"
          quickCheck $ \ns -> let xs = ns :: [Number] in
                              testObservable (\v -> pure id <*> v) xs == xs
          trace "Composition"
          quickCheck $ \ns -> let u = create (\o -> o |> onNext (\x -> x * x + 2 * x + 1)) :: Observable (State [Number]) (Number -> Number)
                                  v = create (\o -> o |> onNext (\x -> x * x * x + 3 * x + 5)) :: Observable (State [Number]) (Number -> Number)
                                  w = toObservable ns :: Observable (State [Number]) Number
                                  xs = (pure (<<<)) <*> u <*> v <*> w :: Observable (State [(Number)]) Number
                                  ys = u <*> (v <*> w) :: Observable (State [(Number)]) (Number)
                             in  toList xs == toList ys


Update config text

Update config text

module IdePurescript.Atom.Config (config) where

import Prelude((++),(==))
import Node.Process as P
import Node.Platform (Platform(Win32))

pulpCmd :: String
pulpCmd = if P.platform == Win32 then "pulp.cmd" else "pulp"

config =
  { pscIdePort:
    { title: "psc-ide port number"
    , description: "The port to use to communciate with `psc-ide-server`, also to launch the server with if required. "
        ++ "The default port is 4242 and this only need be changed if you've explicitly chosen to use another port."
    , type: "integer"
    , default: 4242
    }
  , pscIdeServerExe:
    { title: "psc-ide-server executable location"
    , description: "The location of the `psc-ide-server` executable. Note this is *not* `psc-ide-client`. May be on the PATH."
    , type: "string"
    , default: "psc-ide-server"
    }
  , buildCommand:
    { title: "build command"
    , description: "Command line to build the project. "
        ++ "Could be pulp (default), psc or a gulpfile, so long as it passes through errors from psc. "
        ++ "Should output json errors (`--json-errors` flag). "
        ++ "This is not interpreted via a shell, arguments can be specified but don't use shell features or a command with spaces in its path."
        ++ "See [examples on the README](https://github.com/nwolverson/atom-ide-purescript/#build-configuration-hints)"
    , type: "string"
    , default: pulpCmd ++ " build --no-psa --json-errors"
    }
  , buildOnSave:
    { title: "build on save"
    , description: "Build automatically on save. Enables in-line and collected errors. Otherwise a build command is available to be invoked manually."
    , type: "boolean"
    , default: true
    }
  , psciCommand:
    { title: "psci command (eg 'psci' or 'pulp psci' or full path)"
    , description: "Command line to use to launch PSCI for the repl buffer. "
        ++ "This is not interpreted via a shell, arguments can be specified but don't use shell features or a command with spaces in its path."
    , type: "string"
    , default: pulpCmd ++ " psci"
    }
  }

module IdePurescript.Atom.Config (config) where

import Prelude((++),(==))
import Node.Process as P
import Node.Platform (Platform(Win32))

pulpCmd :: String
pulpCmd = if P.platform == Win32 then "pulp.cmd" else "pulp"

config =
  { pscIdePort:
    { title: "psc-ide port number"
    , type: "integer"
    , default: 4242
    }
  , pscIdeServerExe:
    { title: "psc-ide-server executable location"
    , type: "string"
    , default: "psc-ide-server"
    }
  , buildCommand:
    { title: "build command"
    , description: "Command line to build the project. Could be pulp (default), psc or a gulpfile, so long as it passes through errors from psc. Should output json errors (old format will still be supported for now). Don't use a command with spaces in its path."
    , type: "string"
    , default: pulpCmd ++ " build --no-psa --json-errors"
    }
  , buildOnSave:
    { title: "build on save"
    , description: "Build automatically on save. Enables in-line and collected errors. Otherwise a build command is available to be invoked manually."
    , type: "boolean"
    , default: true
    }
  , psciCommand:
    { title: "psci command (eg 'psci' or 'pulp psci' or full path)"
    , description: "Command line to use to launch PSCI for the repl buffer. Don't use a command with spaces in its path."
    , type: "string"
    , default: pulpCmd ++ " psci"
    }
  }


Use revised TextMode constructor

Use revised TextMode constructor

module App.Notebook.Ace (acePostRender, ref, AceKnot()) where

import Input.Notebook (CellResultContent(..), Input(..))

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (Ref(), RefVal(), readRef, newRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import qualified Ace.Config as AceConfig
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), ACE(), Editor(), TextMode(..))
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId)

import Optic.Core
import Optic.Refractor.Lens

type AceKnot = Tuple CellId (M.Map CellId EditSession)

markdownMode :: TextMode
markdownMode = TextMode "ace/mode/markdown"

sqlMode :: TextMode
sqlMode = TextMode "ace/mode/sql"

plainTextMode :: TextMode
plainTextMode = TextMode "ace/mode/plain_text"

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  "query" -> sqlMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

initialize :: forall eff. RefVal AceKnot -> HTMLElement ->
              Driver Input (ace :: ACE | eff) ->
              Eff (HalogenEffects (ace :: ACE | eff)) Unit
initialize m b d = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ++ "js/ace")
  els <- getElementsByClassName "ace-container" b
  Tuple _ mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace
      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (_2 %~ M.insert cid session)
    Editor.onFocus editor do
      modifyRef m (_1 .~ cid)
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceKnot
                        -> Input
                        -> Driver Input (now :: Now, ace :: ACE | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
handleInput m (RunCell cellId _) d = do
  Tuple _ m' <- readRef m
  now' <- now
  maybe (return unit) (getValue >=> d <<< CellResult cellId now' <<< Right <<< AceContent) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (_2 %~ M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceKnot -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: ACE | eff) -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d

ref :: forall e.  Eff (ref :: Ref | e) (RefVal AceKnot)
ref = newRef (Tuple 0 M.empty)

module App.Notebook.Ace (acePostRender, ref, AceKnot()) where

import Input.Notebook (CellResultContent(..), Input(..))

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (Ref(), RefVal(), readRef, newRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import qualified Ace.Config as AceConfig
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), ACE(), Editor(), TextMode())
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId)

import Optic.Core
import Optic.Refractor.Lens

type AceKnot = Tuple CellId (M.Map CellId EditSession)

foreign import markdownMode """
  var markdownMode = "ace/mode/markdown";
""" :: TextMode

foreign import sqlMode """
  var sqlMode = "ace/mode/sql";
""" :: TextMode

foreign import plainTextMode """
  var plainTextMode = "ace/mode/plain_text";
""" :: TextMode

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  "query" -> sqlMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

initialize :: forall eff. RefVal AceKnot -> HTMLElement ->
              Driver Input (ace :: ACE | eff) ->
              Eff (HalogenEffects (ace :: ACE | eff)) Unit
initialize m b d = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ++ "js/ace")
  els <- getElementsByClassName "ace-container" b
  Tuple _ mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace
      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (_2 %~ M.insert cid session)
    Editor.onFocus editor do
      modifyRef m (_1 .~ cid)
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceKnot
                        -> Input
                        -> Driver Input (now :: Now, ace :: ACE | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
handleInput m (RunCell cellId _) d = do
  Tuple _ m' <- readRef m
  now' <- now
  maybe (return unit) (getValue >=> d <<< CellResult cellId now' <<< Right <<< AceContent) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (_2 %~ M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceKnot -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: ACE | eff) -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d

ref :: forall e.  Eff (ref :: Ref | e) (RefVal AceKnot)
ref = newRef (Tuple 0 M.empty)


`nullary` now called by `binding` instead of `constrLit`

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , Associativity(..)
  , DataCons(..)
  , Type(..)
  , AD(..))
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> pure a

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~','_'
  ,'°']

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> pure true
      <|> string "False" *> pure false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  pure c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> pure '\n')
         <|> (char 'r' *> pure '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

-- | Parser for type names
typeName :: forall m. (Monad m) => ParserT String m String
typeName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.singleton) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String TypeTree
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> pure (Binary Nothing (toOpTuple op))) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> (Atom Nothing (AInt (-ai)))
            _                -> Unary Nothing (toOpTuple Sub) e

    infixOperator :: Operator m String TypeTree
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          pure $ \e1 e2 -> Binary Nothing (toOpTuple $ InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> pure op)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      pure $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String TypeTree -> IndentParser String TypeTree
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom Nothing <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String TypeTree -> IndentParser String TypeTree
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> pure $ App Nothing e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  pure $ IfExpr Nothing testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> pure $ NTuple Nothing (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> pure $ PrefixOp Nothing op
        Just e2 -> pure $ SectR Nothing op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL Nothing e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ List Nothing exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  pure $ ArithmSeq Nothing start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListComp Nothing start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          pure $ Let Nothing b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen Nothing b e
        parseGuard = ilexe expr >>= (pure <<< Guard Nothing)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List Nothing ((Atom Nothing <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  pure $ Lambda Nothing binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  pure $ LetExpr Nothing binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding MType) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

-- | Parse an arbitrary expression
expression :: IndentParser String TypeTree
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT src p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m (Binding MType)
lit = Lit Nothing <$> atom

consLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  pure b
  where
    consLit' :: IndentParser String (Binding MType)
    consLit' = do
      b <- ilexe $ bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent bnd)
      pure $ ConsLit Nothing b bs

listLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
listLit bnd = do
  ilexe $ char '['
  bs <- (indent bnd) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListLit Nothing bs

tupleLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
tupleLit bnd = do
  ilexe $ char '('
  b <- indent bnd
  indent $ char ','
  bs <- (indent bnd) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  pure $ NTupleLit Nothing (Cons b bs)

constrLit :: FixedIndentParser String (Binding MType)
constrLit bnd = PC.try (prefConstrLit bnd) <|> (infConstrLit bnd)

nullary :: IndentParser String (Binding MType)
nullary = do
  n <- indent typeName
  pure $ ConstrLit Nothing (PrefixCons n 0 Nil)

prefConstrLit :: FixedIndentParser String (Binding MType)
prefConstrLit bnd = do
  ilexe $ char '('
  n <- indent typeName
  as   <- many (indent bnd)
  ilexe $ char ')'
  pure $ ConstrLit Nothing (PrefixCons n (length as) as)

infConstrLit :: FixedIndentParser String (Binding MType)
infConstrLit bnd = do
  ilexe $ char '('
  l <- indent bnd
  o <- indent infixConstructor
  r <- indent bnd
  ilexe $ char ')'
  pure $ ConstrLit Nothing (InfixCons o LEFTASSOC 9 l r)

binding :: IndentParser String (Binding MType)
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (PC.try $ constrLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit
  <|> nullary

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
{-
  <TYPE>    --> <TYPE1> [ `->` <TYPE> ]
  <TYPE1>   --> <SIMPLE>
              | <TYPEVAR>
              | `[` <TYPE> `]`
              | <CONS> { <TYPE> }
              | `(` <TYPE> `)`
              | `(` <TYPE> { `,` <TYPE> } `)`
  <SIMPLE>  --> `Int` | `Bool` | `Char`
-}

simpleType :: IndentParser String Type
simpleType =
  TypCon <$> (string "Bool"
             <|> string "Int"
             <|> string "Char")
  <|> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe typeName
  ps <- many (indent $ typeExpr t <|> simpleType)
  pure $ AD $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (indent (char '('))
  (indent (char ')'))
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> PC.chainr1
    (indent (types1 t))
    (indent (string "->") *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe (char '('))
  (PC.try $ indent (char ')'))
  (do ts <- PC.sepBy1 (indent t) (PC.try (indent (char ',')))
      when (length ts <= 1) (fail "Tuple to short.")
      pure (AD (TTuple ts)))

types1 :: IndentParser String Type -> IndentParser String Type
types1 t =
  PC.try simpleType
  <|> AD <<< TList <$> (ilexe (char '[') *> indent t <* indent (char ']'))
  <|> typeCons t
  <|> PC.try (typeExpr t)
  <|> typeTuple t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent typeName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataCons Type)
dataConstructorDefinition
  = PC.try prefixDataConstructorDefinition
  <|> infixDataConstructorDefinition

prefixDataConstructorDefinition :: IndentParser String (DataCons Type)
prefixDataConstructorDefinition = do
  n <- ilexe typeName
  ps <- many types
  pure $ PrefixCons n (length ps) ps

infixDataConstructorDefinition :: IndentParser String (DataCons Type)
infixDataConstructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixCons o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , Associativity(..)
  , DataCons(..)
  , Type(..)
  , AD(..))
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> pure a

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~','_'
  ,'°']

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> pure true
      <|> string "False" *> pure false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  pure c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> pure '\n')
         <|> (char 'r' *> pure '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

-- | Parser for type names
typeName :: forall m. (Monad m) => ParserT String m String
typeName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.singleton) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String TypeTree
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> pure (Binary Nothing (toOpTuple op))) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> (Atom Nothing (AInt (-ai)))
            _                -> Unary Nothing (toOpTuple Sub) e

    infixOperator :: Operator m String TypeTree
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          pure $ \e1 e2 -> Binary Nothing (toOpTuple $ InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> pure op)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      pure $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String TypeTree -> IndentParser String TypeTree
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom Nothing <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String TypeTree -> IndentParser String TypeTree
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> pure $ App Nothing e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  pure $ IfExpr Nothing testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> pure $ NTuple Nothing (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> pure $ PrefixOp Nothing op
        Just e2 -> pure $ SectR Nothing op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL Nothing e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ List Nothing exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  pure $ ArithmSeq Nothing start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListComp Nothing start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          pure $ Let Nothing b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen Nothing b e
        parseGuard = ilexe expr >>= (pure <<< Guard Nothing)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List Nothing ((Atom Nothing <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  pure $ Lambda Nothing binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  pure $ LetExpr Nothing binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding MType) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

-- | Parse an arbitrary expression
expression :: IndentParser String TypeTree
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT src p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m (Binding MType)
lit = Lit Nothing <$> atom

consLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  pure b
  where
    consLit' :: IndentParser String (Binding MType)
    consLit' = do
      b <- ilexe $ bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent bnd)
      pure $ ConsLit Nothing b bs

listLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
listLit bnd = do
  ilexe $ char '['
  bs <- (indent bnd) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListLit Nothing bs

tupleLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
tupleLit bnd = do
  ilexe $ char '('
  b <- indent bnd
  indent $ char ','
  bs <- (indent bnd) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  pure $ NTupleLit Nothing (Cons b bs)

constrLit :: FixedIndentParser String (Binding MType)
constrLit bnd = nullary <|> PC.try (prefConstrLit bnd) <|> (infConstrLit bnd)

nullary :: IndentParser String (Binding MType)
nullary = do
  n <- indent typeName
  pure $ ConstrLit Nothing (PrefixCons n 0 Nil)

prefConstrLit :: FixedIndentParser String (Binding MType)
prefConstrLit bnd = do
  ilexe $ char '('
  n <- indent typeName
  as   <- many (indent bnd)
  ilexe $ char ')'
  pure $ ConstrLit Nothing (PrefixCons n (length as) as)

infConstrLit :: FixedIndentParser String (Binding MType)
infConstrLit bnd = do
  ilexe $ char '('
  l <- indent bnd
  o <- indent infixConstructor
  r <- indent bnd
  ilexe $ char ')'
  pure $ ConstrLit Nothing (InfixCons o LEFTASSOC 9 l r)

binding :: IndentParser String (Binding MType)
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (PC.try $ constrLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
{-
  <TYPE>    --> <TYPE1> [ `->` <TYPE> ]
  <TYPE1>   --> <SIMPLE>
              | <TYPEVAR>
              | `[` <TYPE> `]`
              | <CONS> { <TYPE> }
              | `(` <TYPE> `)`
              | `(` <TYPE> { `,` <TYPE> } `)`
  <SIMPLE>  --> `Int` | `Bool` | `Char`
-}

simpleType :: IndentParser String Type
simpleType =
  TypCon <$> (string "Bool"
             <|> string "Int"
             <|> string "Char")
  <|> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe typeName
  ps <- many (indent $ typeExpr t <|> simpleType)
  pure $ AD $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (indent (char '('))
  (indent (char ')'))
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> PC.chainr1
    (indent (types1 t))
    (indent (string "->") *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe (char '('))
  (PC.try $ indent (char ')'))
  (do ts <- PC.sepBy1 (indent t) (PC.try (indent (char ',')))
      when (length ts <= 1) (fail "Tuple to short.")
      pure (AD (TTuple ts)))

types1 :: IndentParser String Type -> IndentParser String Type
types1 t =
  PC.try simpleType
  <|> AD <<< TList <$> (ilexe (char '[') *> indent t <* indent (char ']'))
  <|> typeCons t
  <|> PC.try (typeExpr t)
  <|> typeTuple t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent typeName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataCons Type)
dataConstructorDefinition
  = PC.try prefixDataConstructorDefinition
  <|> infixDataConstructorDefinition

prefixDataConstructorDefinition :: IndentParser String (DataCons Type)
prefixDataConstructorDefinition = do
  n <- ilexe typeName
  ps <- many types
  pure $ PrefixCons n (length ps) ps

infixDataConstructorDefinition :: IndentParser String (DataCons Type)
infixDataConstructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixCons o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms


Move joinWith from Data.Array

Move joinWith from Data.Array

module Data.String where

foreign import charAt
  "function charAt(i) {\
  \  return function(s) {\
  \    return s.charAt(i); \
  \  };\
  \}" :: Number -> String -> String

foreign import fromCharCode
  "function fromCharCode(n) {\
  \  return String.fromCharCode(n);\
  \}" :: Number -> String

foreign import indexOf
  "function indexOf(s1) {\
  \  return function(s2) {\
  \    return s1.indexOf(s2);\
  \  }; \
  \}" :: String -> String -> Number

foreign import lastIndexOf
  "function lastIndexOf(s1) {\
  \  return function(s2) {\
  \    return s1.lastIndexOf(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import length
  "function length(s) {\
  \  return s.length;\
  \}" :: String -> Number

foreign import localeCompare
  "function localeCompare(s1) {\
  \  return function(s2) {\
  \    return s1.localeCompare(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import replace
  "function replace(s1) {\
  \  return function(s2) {\
  \    return function(s3) {\
  \      return s3.replace(s1, s2);\
  \    };\
  \  };\
  \}" :: String -> String -> String -> String

foreign import slice
  "function slice(st) {\
  \  return function(e) {\
  \    return function(s) {\
  \      return s.slice(st, e);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import split
  "function split(sep) {\
  \  return function(s) {\
  \    return s.split(sep);\
  \  };\
  \}" :: String -> String -> [String]

foreign import substr
  "function substr(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substr(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import substring
  "function substring(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substring(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import toLower
  "function toLower(s) {\
  \  return s.toLowerCase();\
  \}" :: String -> String

foreign import toUpper
  "function toUpper(s) {\
  \  return s.toUpperCase();\
  \}" :: String -> String

foreign import trim
  "function trim(s) {\
  \  return s.trim();\
  \}" :: String -> String

foreign import joinWith
  "function joinWith (l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String