Base guard on `toKeys` also

Base guard on `toKeys` also

...the more we base on `toKeys`, the more we know the output will
fit into the hash-map, which has a very limited scope.

module Language.Docopt.Trans (
    reduce
  , byName
  ) where

import Prelude
import Debug.Trace
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Bifunctor (lmap)
import Data.Array as A
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map())
import Data.String (fromChar)
import Data.Monoid (mempty)
import Data.Map as Map
import Data.String as Str
import Data.Tuple (Tuple(..), fst)
import Control.MonadPlus (guard)
import Data.Function (on)
import Language.Docopt.Env (Env())
import Language.Docopt.Usage    as D
import Language.Docopt.Errors   as D
import Language.Docopt.Env      as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Option   as O
import Language.Docopt.Env      as Env
import Data.String.Ext ((^=))
import Data.List (List(..), toList, concat, singleton, groupBy, catMaybes)
import Data.List as L
import Language.Docopt.ParserGen.ValueMapping

-- | Derive a key from an argument.
-- | This key is what the user will use to check the value of
-- | a mathed argument.
toKeys :: D.Argument -> Array String
toKeys (D.Command n)      = [n]
toKeys (D.Positional n _) = [ "<" ++ Str.toLower n ++ ">"
                            , Str.toUpper n
                            ]
toKeys (D.Group _ _ _)    = []
toKeys (D.EOA)            = ["--"]
toKeys (D.Stdin)          = ["-"]
toKeys (D.Option (O.Option o))
                          = []
                          ++ maybe [] (\c -> [ "-"  ++ fromChar c ]) o.flag
                          ++ maybe [] (\s -> [ "--" ++ s ]) o.name

-- | Combine two arguments into one.
combine :: D.Argument -> D.Argument -> D.Argument
combine (x@(D.Positional n r)) (y@(D.Positional n' r'))
  | (eq `on` toKeys) x y
  = D.Positional n (r || r')
combine (x@(D.Option (O.Option o))) (y@(D.Option (O.Option o')))
  | (eq `on` toKeys) x y
  = D.Option $ O.Option $ o { repeatable = o.repeatable || o'.repeatable }
combine a _ = a

-- | Transform the map of (Argument, Value) mappings to a map of (String, Value),
-- | where the String is the name of the option and it's aliases.
-- | This means that Arguments that resolve to the same name/alias must be
-- | somehow resolved.
byName :: Map D.Argument D.Value -> Map String D.Value
byName m
  = foldl (Map.unionWith resolve)
          Map.empty
          (L.concat $ Map.toList m <#> \(Tuple k v) ->
            toList $ toKeys k <#> \k' -> Map.singleton k' v)
  where
    -- This *should* be safe, since all confusion should have been
    -- lifted by the `reduce` function. This function cannot be implemented
    -- other than selecting one of the values verbatim, because it's lacking
    -- all context about these values (i.e. the Argument they belong to).
    resolve :: D.Value -> D.Value -> D.Value
    resolve _ v' = v'

-- | Reduce the list of (Argument, Value) mappings down to a Set.
-- | This means that duplicate Arguments must somehow be resolved.
-- |
-- | XXX: How to solve the following issues:
-- |
-- |  * Two options differ in:
-- |      * Their argument name           -> ?
-- |      * Their argument default value  -> ?
-- |
reduce :: List D.Usage           -- ^ the program specification
       -> D.Env                  -- ^ the environment
       -> D.Branch               -- ^ the matched specification
       -> List ValueMapping      -- ^ the parse result
       -> Map D.Argument D.Value -- ^ the output set of (arg => val)
reduce us env _ vs =
  let prg = D.Branch $ unify' $ concat
              $ (D.runBranch)
                <$> (concat $ (flatten <$>) <<< D.runUsage <$> us)
      uni = lmap (\v -> foldl combine v (D.runBranch prg)) <$> vs
   in toValMap uni
    # applyEnvVals prg
    # applyDefVals prg

  where

    -- | Remove all groups from the branch, by concatenation
    flatten :: D.Branch -> D.Branch
    flatten (D.Branch bs) = D.Branch $ foldl (\a b -> a ++ expand b) mempty bs
      where
        expand :: D.Argument -> List D.Argument
        expand (D.Group _ xs r)
          = concat $ concat
            $ xs <#> D.runBranch
                      >>> ((expand >>> ((flip D.setRepeatableOr r) <$>)) <$>)
        expand x = singleton x

    unify' :: List D.Argument -> List D.Argument
    unify' xs =
      let ys = groupBy (eq `on` toKeys) xs
       in catMaybes $ ys <#> \y ->
            case y of
                Cons z zs -> Just $ foldl combine z zs
                Nil       -> Nothing

    toValMap :: List (Tuple D.Argument D.Value) -> Map D.Argument D.Value
    toValMap vs = foldl step Map.empty (prepare <$> vs)
      where
        step :: Map D.Argument D.Value
             -> Tuple D.Argument D.Value
             -> Map D.Argument D.Value
        step m (Tuple k v) = Map.unionWith (resolve k) (Map.singleton k v) m

        prepare :: Tuple D.Argument D.Value -> Tuple D.Argument D.Value
        prepare (Tuple k v) | D.isRepeatable k
          = Tuple k (D.ArrayValue $
              (case v of
                D.ArrayValue xs -> xs
                _               -> [v]
              ))
        prepare k = k

        resolve :: D.Argument -> D.Value -> D.Value -> D.Value
        resolve _ (D.ArrayValue xs) (D.ArrayValue xs') = D.ArrayValue (xs' ++ xs)
        resolve _ (D.ArrayValue xs) v = D.ArrayValue (v A.: xs)
        resolve a v v' | D.isRepeatable a
          = D.ArrayValue $
              (case v' of
                D.ArrayValue xs -> xs
                _               -> [v']
              ) ++ [v]
        resolve _ v v' = v

    applyEnvVals :: D.Branch               -- ^ the specification
                 -> Map D.Argument D.Value -- ^ the input set
                 -> Map D.Argument D.Value -- ^ the output set
    applyEnvVals (D.Branch b) m = foldl step m b
      where
        step :: Map D.Argument D.Value
             -> D.Argument
             -> Map D.Argument D.Value
        step m d = maybe m (`Map.unionWith resolve` m)
                           (Map.singleton d <$> toEnvVal d)

        resolve :: D.Value -> D.Value -> D.Value
        resolve _ v = v -- choose existing value, not env

        toEnvVal :: D.Argument -> Maybe D.Value
        toEnvVal (D.Option (O.Option o@{ env: Just k }))
          = D.StringValue <$> Env.lookup k env
        toEnvVal _ = Nothing

    applyDefVals :: D.Branch               -- ^ the specification
                 -> Map D.Argument D.Value -- ^ the input set
                 -> Map D.Argument D.Value -- ^ the output set
    applyDefVals (D.Branch b) m = foldl step m b
      where
        step :: Map D.Argument D.Value
             -> D.Argument
             -> Map D.Argument D.Value
        step m d =
          let defaults = Map.singleton d <$> toDefVal d
           in maybe m (m `Map.unionWith resolve`) defaults

        resolve :: D.Value -> D.Value -> D.Value
        resolve v _ = v -- choose existing value, not default

        toDefVal :: D.Argument -> Maybe D.Value

        -- Handle options that have an explicit argument binding.
        toDefVal (D.Option (O.Option o@{
                  arg: Just (O.Argument { default: Just v })
                }))
          = return $
              if (D.isArrayValue v || not o.repeatable)
                then v
                else D.ArrayValue [v]

        -- Handle option flags. Flags indicate only truthiness via their
        -- presence. Absent flags are always falsy!
        toDefVal (D.Option (O.Option o@{ arg: Nothing }))
          = return $ if o.repeatable
              then D.ArrayValue [ D.BoolValue false ]
              else D.BoolValue false

        toDefVal (D.Positional _ r)
          = if r
              then return $ D.ArrayValue []
              else Nothing

        toDefVal (D.EOA) = Just $ D.ArrayValue []

        toDefVal _ = Nothing

module Language.Docopt.Trans (
    reduce
  , byName
  ) where

import Prelude
import Debug.Trace
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Bifunctor (lmap)
import Data.Array as A
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map())
import Data.String (fromChar)
import Data.Monoid (mempty)
import Data.Map as Map
import Data.String as Str
import Data.Tuple (Tuple(..), fst)
import Control.MonadPlus (guard)
import Data.Function (on)
import Language.Docopt.Env (Env())
import Language.Docopt.Usage    as D
import Language.Docopt.Errors   as D
import Language.Docopt.Env      as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Option   as O
import Language.Docopt.Env      as Env
import Data.String.Ext ((^=))
import Data.List (List(..), toList, concat, singleton, groupBy, catMaybes)
import Data.List as L
import Language.Docopt.ParserGen.ValueMapping

-- | Derive a key from an argument.
-- | This key is what the user will use to check the value of
-- | a mathed argument.
toKeys :: D.Argument -> Array String
toKeys (D.Command n)      = [n]
toKeys (D.Positional n _) = [ "<" ++ Str.toLower n ++ ">"
                            , Str.toUpper n
                            ]
toKeys (D.Group _ _ _)    = []
toKeys (D.EOA)            = ["--"]
toKeys (D.Stdin)          = ["-"]
toKeys (D.Option (O.Option o))
                          = []
                          ++ maybe [] (\c -> [ "-"  ++ fromChar c ]) o.flag
                          ++ maybe [] (\s -> [ "--" ++ s ]) o.name

-- | Combine two arguments into one.
combine :: D.Argument -> D.Argument -> D.Argument
combine (D.Positional n r) (D.Positional n' r') | n ^= n'
  = D.Positional n (r || r')
combine (D.Option (O.Option o)) (D.Option (O.Option o'))
  |    (o.name == o'.name)
    && (o.flag == o'.flag)
    && ((isNothing o.arg && isNothing o'.arg) || isJust do
          (O.Argument { name: an  }) <- o.arg
          (O.Argument { name: an' }) <- o'.arg
          guard (an ^= an')
        )
  = D.Option $ O.Option $ o {
      repeatable = o.repeatable || o'.repeatable
    }
combine a _ = a

-- | Transform the map of (Argument, Value) mappings to a map of (String, Value),
-- | where the String is the name of the option and it's aliases.
-- | This means that Arguments that resolve to the same name/alias must be
-- | somehow resolved.
byName :: Map D.Argument D.Value -> Map String D.Value
byName m
  = foldl (Map.unionWith resolve)
          Map.empty
          (L.concat $ Map.toList m <#> \(Tuple k v) ->
            toList $ toKeys k <#> \k' -> Map.singleton k' v)
  where
    -- This *should* be safe, since all confusion should have been
    -- lifted by the `reduce` function. This function cannot be implemented
    -- other than selecting one of the values verbatim, because it's lacking
    -- all context about these values (i.e. the Argument they belong to).
    resolve :: D.Value -> D.Value -> D.Value
    resolve _ v' = v'

-- | Reduce the list of (Argument, Value) mappings down to a Set.
-- | This means that duplicate Arguments must somehow be resolved.
-- |
-- | XXX: How to solve the following issues:
-- |
-- |  * Two options differ in:
-- |      * Their argument name           -> ?
-- |      * Their argument default value  -> ?
-- |
reduce :: List D.Usage           -- ^ the program specification
       -> D.Env                  -- ^ the environment
       -> D.Branch               -- ^ the matched specification
       -> List ValueMapping      -- ^ the parse result
       -> Map D.Argument D.Value -- ^ the output set of (arg => val)
reduce us env _ vs =
  let prg = D.Branch $ unify' $ concat
              $ (D.runBranch)
                <$> (concat $ (flatten <$>) <<< D.runUsage <$> us)
      uni = lmap (\v -> foldl combine v (D.runBranch prg)) <$> vs
   in toValMap uni
    # applyEnvVals prg
    # applyDefVals prg

  where

    -- | Remove all groups from the branch, by concatenation
    flatten :: D.Branch -> D.Branch
    flatten (D.Branch bs) = D.Branch $ foldl (\a b -> a ++ expand b) mempty bs
      where
        expand :: D.Argument -> List D.Argument
        expand (D.Group _ xs r)
          = concat $ concat
            $ xs <#> D.runBranch
                      >>> ((expand >>> ((flip D.setRepeatableOr r) <$>)) <$>)
        expand x = singleton x

    unify' :: List D.Argument -> List D.Argument
    unify' xs =
      let ys = groupBy (eq `on` toKeys) xs
       in catMaybes $ ys <#> \y ->
            case y of
                Cons z zs -> Just $ foldl combine z zs
                Nil       -> Nothing

    toValMap :: List (Tuple D.Argument D.Value) -> Map D.Argument D.Value
    toValMap vs = foldl step Map.empty (prepare <$> vs)
      where
        step :: Map D.Argument D.Value
             -> Tuple D.Argument D.Value
             -> Map D.Argument D.Value
        step m (Tuple k v) = Map.unionWith (resolve k) (Map.singleton k v) m

        prepare :: Tuple D.Argument D.Value -> Tuple D.Argument D.Value
        prepare (Tuple k v) | D.isRepeatable k
          = Tuple k (D.ArrayValue $
              (case v of
                D.ArrayValue xs -> xs
                _               -> [v]
              ))
        prepare k = k

        resolve :: D.Argument -> D.Value -> D.Value -> D.Value
        resolve _ (D.ArrayValue xs) (D.ArrayValue xs') = D.ArrayValue (xs' ++ xs)
        resolve _ (D.ArrayValue xs) v = D.ArrayValue (v A.: xs)
        resolve a v v' | D.isRepeatable a
          = D.ArrayValue $
              (case v' of
                D.ArrayValue xs -> xs
                _               -> [v']
              ) ++ [v]
        resolve _ v v' = v

    applyEnvVals :: D.Branch               -- ^ the specification
                 -> Map D.Argument D.Value -- ^ the input set
                 -> Map D.Argument D.Value -- ^ the output set
    applyEnvVals (D.Branch b) m = foldl step m b
      where
        step :: Map D.Argument D.Value
             -> D.Argument
             -> Map D.Argument D.Value
        step m d = maybe m (`Map.unionWith resolve` m)
                           (Map.singleton d <$> toEnvVal d)

        resolve :: D.Value -> D.Value -> D.Value
        resolve _ v = v -- choose existing value, not env

        toEnvVal :: D.Argument -> Maybe D.Value
        toEnvVal (D.Option (O.Option o@{ env: Just k }))
          = D.StringValue <$> Env.lookup k env
        toEnvVal _ = Nothing

    applyDefVals :: D.Branch               -- ^ the specification
                 -> Map D.Argument D.Value -- ^ the input set
                 -> Map D.Argument D.Value -- ^ the output set
    applyDefVals (D.Branch b) m = foldl step m b
      where
        step :: Map D.Argument D.Value
             -> D.Argument
             -> Map D.Argument D.Value
        step m d =
          let defaults = Map.singleton d <$> toDefVal d
           in maybe m (m `Map.unionWith resolve`) defaults

        resolve :: D.Value -> D.Value -> D.Value
        resolve v _ = v -- choose existing value, not default

        toDefVal :: D.Argument -> Maybe D.Value

        -- Handle options that have an explicit argument binding.
        toDefVal (D.Option (O.Option o@{
                  arg: Just (O.Argument { default: Just v })
                }))
          = return $
              if (D.isArrayValue v || not o.repeatable)
                then v
                else D.ArrayValue [v]

        -- Handle option flags. Flags indicate only truthiness via their
        -- presence. Absent flags are always falsy!
        toDefVal (D.Option (O.Option o@{ arg: Nothing }))
          = return $ if o.repeatable
              then D.ArrayValue [ D.BoolValue false ]
              else D.BoolValue false

        toDefVal (D.Positional _ r)
          = if r
              then return $ D.ArrayValue []
              else Nothing

        toDefVal (D.EOA) = Just $ D.ArrayValue []

        toDefVal _ = Nothing


Avoid Discard constraints

Avoid Discard constraints

module Data.Array.ST.Iterator
  ( Iterator
  , iterator
  , iterate
  , next
  , peek
  , exhausted
  , pushWhile
  , pushAll
  ) where

import Prelude
import Control.Monad.Eff (Eff, whileE)
import Control.Monad.ST (ST, STRef, newSTRef, readSTRef, writeSTRef, modifySTRef)
import Data.Array.ST (STArray, pushSTArray)

import Data.Maybe (Maybe(..), isNothing)

-- | This type provides a slightly easier way of iterating over an array's
-- | elements in an STArray computation, without having to keep track of
-- | indices.
data Iterator h a = Iterator (Int -> Maybe a) (STRef h Int)

-- | Make an Iterator given an indexing function into an array (or anything
-- | else). If `xs :: Array a`, the standard way to create an iterator over
-- | `xs` is to use `iterator (xs !! _)`, where `(!!)` comes from `Data.Array`.
iterator :: forall a h r. (Int -> Maybe a) -> Eff (st :: ST h | r) (Iterator h a)
iterator f =
  Iterator f <$> newSTRef 0

-- | Perform an action once for each item left in an iterator. If the action
-- | itself also advances the same iterator, `iterate` will miss those items
-- | out.
iterate :: forall a h r. Iterator h a -> (a -> Eff (st :: ST h | r) Unit) -> Eff (st :: ST h | r) Unit
iterate iter f = do
  break <- newSTRef false
  whileE (not <$> readSTRef break) do
    mx <- next iter
    case mx of
      Just x -> f x
      Nothing -> void $ writeSTRef break true

-- | Get the next item out of an iterator, advancing it. Returns Nothing if the
-- | Iterator is exhausted.
next :: forall a h r. Iterator h a -> Eff (st :: ST h | r) (Maybe a)
next (Iterator f currentIndex) = do
  i <- readSTRef currentIndex
  _ <- modifySTRef currentIndex (_ + 1)
  pure (f i)

-- | Get the next item out of an iterator without advancing it.
peek :: forall a h r. Iterator h a -> Eff (st :: ST h | r) (Maybe a)
peek (Iterator f currentIndex) = do
  i <- readSTRef currentIndex
  pure (f i)

-- | Check whether an iterator has been exhausted.
exhausted :: forall a h r. Iterator h a -> Eff (st :: ST h | r) Boolean
exhausted = map isNothing <<< peek

-- | Extract elements from an iterator and push them on to an STArray for as
-- | long as those elements satisfy a given predicate.
pushWhile :: forall a h r. (a -> Boolean) -> Iterator h a -> STArray h a -> Eff (st :: ST h | r) Unit
pushWhile p iter array = do
  break <- newSTRef false
  whileE (not <$> readSTRef break) do
    mx <- peek iter
    case mx of
      Just x | p x -> do
        _ <- pushSTArray array x
        void $ next iter
      _ ->
        void $ writeSTRef break true

-- | Push the entire remaining contents of an iterator onto an STArray.
pushAll :: forall a h r. Iterator h a -> STArray h a -> Eff (st :: ST h | r) Unit
pushAll = pushWhile (const true)

module Data.Array.ST.Iterator
  ( Iterator
  , iterator
  , iterate
  , next
  , peek
  , exhausted
  , pushWhile
  , pushAll
  ) where

import Prelude
import Control.Monad.Eff (Eff, whileE)
import Control.Monad.ST (ST, STRef, newSTRef, readSTRef, writeSTRef, modifySTRef)
import Data.Array.ST (STArray, pushSTArray)

import Data.Maybe (Maybe(..), isNothing)

-- | This type provides a slightly easier way of iterating over an array's
-- | elements in an STArray computation, without having to keep track of
-- | indices.
data Iterator h a = Iterator (Int -> Maybe a) (STRef h Int)

-- | Make an Iterator given an indexing function into an array (or anything
-- | else). If `xs :: Array a`, the standard way to create an iterator over
-- | `xs` is to use `iterator (xs !! _)`, where `(!!)` comes from `Data.Array`.
iterator :: forall a h r. (Int -> Maybe a) -> Eff (st :: ST h | r) (Iterator h a)
iterator f =
  Iterator f <$> newSTRef 0

-- | Perform an action once for each item left in an iterator. If the action
-- | itself also advances the same iterator, `iterate` will miss those items
-- | out.
iterate :: forall a h r. Iterator h a -> (a -> Eff (st :: ST h | r) Unit) -> Eff (st :: ST h | r) Unit
iterate iter f = do
  break <- newSTRef false
  whileE (not <$> readSTRef break) do
    mx <- next iter
    case mx of
      Just x -> f x
      Nothing -> void $ writeSTRef break true

-- | Get the next item out of an iterator, advancing it. Returns Nothing if the
-- | Iterator is exhausted.
next :: forall a h r. Iterator h a -> Eff (st :: ST h | r) (Maybe a)
next (Iterator f currentIndex) = do
  i <- readSTRef currentIndex
  modifySTRef currentIndex (_ + 1)
  pure (f i)

-- | Get the next item out of an iterator without advancing it.
peek :: forall a h r. Iterator h a -> Eff (st :: ST h | r) (Maybe a)
peek (Iterator f currentIndex) = do
  i <- readSTRef currentIndex
  pure (f i)

-- | Check whether an iterator has been exhausted.
exhausted :: forall a h r. Iterator h a -> Eff (st :: ST h | r) Boolean
exhausted = map isNothing <<< peek

-- | Extract elements from an iterator and push them on to an STArray for as
-- | long as those elements satisfy a given predicate.
pushWhile :: forall a h r. (a -> Boolean) -> Iterator h a -> STArray h a -> Eff (st :: ST h | r) Unit
pushWhile p iter array = do
  break <- newSTRef false
  whileE (not <$> readSTRef break) do
    mx <- peek iter
    case mx of
      Just x | p x -> do
        pushSTArray array x
        void $ next iter
      _ ->
        void $ writeSTRef break true

-- | Push the entire remaining contents of an iterator onto an STArray.
pushAll :: forall a h r. Iterator h a -> STArray h a -> Eff (st :: ST h | r) Unit
pushAll = pushWhile (const true)


Add wrapper for closest

Add wrapper for closest

module Control.Monad.JQuery where

import Data.Foreign
import Control.Monad.Eff

-- An effect type which indicates DOM manipulation
foreign import data DOM :: !

-- The jQuery wrapper type
foreign import data JQuery :: *

-- Type of jQuery event objects
foreign import data JQueryEvent :: *

-- $(document).ready(function() { ... })
foreign import ready
  "function ready(func) { \
  \  return function () { \
  \    jQuery(document).ready(func); \
  \  }; \
  \}" :: forall eff a. Eff eff a -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery selection $('..')
foreign import select
  "function select(selector) { \
  \  return function () { \
  \    return jQuery(selector); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .find(...)
foreign import find
  "function select(selector) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.find(selector); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .parent()
foreign import parent
  "function parent(ob) { \
  \  return function () { \
  \    return ob.parent(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .closest(...)
foreign import closest
  "function closest(selector) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.closest(selector); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery creation e.g. $('<div>')
foreign import create
  "function create(html) { \
  \  return function () { \
  \    return jQuery(html); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import setAttr
  "function setAttr(attr) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.attr(attr, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import attr
  "function attr(attrs) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.attr(attrs);\
  \    }; \
  \  }; \
  \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .css({ ... })
foreign import css
  "function css(props) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.css(props); \
  \    }; \
  \  }; \
  \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .hasClass(...)
foreign import hasClass
  "function hasClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.hasClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Boolean

-- .addClass(...)
foreign import addClass
  "function addClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.addClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .removeClass(...)
foreign import removeClass
  "function removeClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.removeClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import setProp
  "function setProp(p) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.prop(p, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import getProp
  "function getProp(p) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.prop(p);\
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Foreign

-- .append(...)
foreign import append
  "function append(ob1) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(ob1); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

foreign import appendAtIndex
  "function appendAtIndex(i) { \
  \  return function(ob1) { \
  \    return function(ob) { \
  \      return function () { \
  \        var children = ob.children();\
  \        if (children.length > 0) {\
  \          if (i <= 0) {\
  \             ob.prepend(ob1);\
  \          } else if (i >= children.length) {\
  \             ob.append(ob1);\
  \          } else {\
  \             ob1.insertBefore(jQuery(children[i]));\
  \          }\
  \          return ob;\
  \        } else {\
  \          return ob.append(ob1); \
  \        }\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .remove()
foreign import remove
  "function remove(ob) { \
  \  return function () { \
  \    return ob.remove(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .empty()
foreign import clear
  "function clear(ob) { \
  \  return function () { \
  \    return ob.empty(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .before(...)
foreign import before
  "function before(ob) { \
  \  return function(ob1) { \
  \    return function () { \
  \      return ob1.before(ob); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .append(...)
foreign import appendText
  "function appendText(s) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(s); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the document body
foreign import body
  "function body() { \
  \  return jQuery(document.body); \
  \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

-- Get the text content of an element
foreign import getText
  "function getText(ob) { \
  \  return function() { \
  \    return ob.text(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

-- Set the text content of an element
foreign import setText
  "function setText(text) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.text(text); \
  \    };\
  \  };\
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the value of a text field
foreign import getValue
  "function getValue(ob) { \
  \  return function() { \
  \    return ob.val(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) Foreign

-- Set the value of a text field
foreign import setValue
  "function setValue(val) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.val(val); \
  \    }; \
  \  }; \
  \}" :: forall eff a. a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on
  "function on(evt) { \
  \  return function(act) { \
  \    return function(ob) { \
  \      return function() { \
  \        return ob.on(evt, function(e) { \
  \          act(e)(jQuery(this))(); \
  \        }); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on'
  "function on$prime(evt) { \
  \  return function(sel) { \
  \    return function(act) { \
  \      return function(ob) { \
  \        return function() { \
  \          return ob.on(evt, sel, function(e) { \
  \            act(e)(jQuery(this))(); \
  \          }); \
  \        }; \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

foreign import preventDefault
  "function preventDefault(e) { \
  \  return function() { \
  \    e.preventDefault(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopPropagation
  "function stopPropagation(e) { \
  \  return function() { \
  \    e.stopPropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopImmediatePropagation
  "function stopImmediatePropagation(e) { \
  \  return function() { \
  \    e.stopImmediatePropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

module Control.Monad.JQuery where

import Data.Foreign
import Control.Monad.Eff

-- An effect type which indicates DOM manipulation
foreign import data DOM :: !

-- The jQuery wrapper type
foreign import data JQuery :: *

-- Type of jQuery event objects
foreign import data JQueryEvent :: *

-- $(document).ready(function() { ... })
foreign import ready
  "function ready(func) { \
  \  return function () { \
  \    jQuery(document).ready(func); \
  \  }; \
  \}" :: forall eff a. Eff eff a -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery selection $('..')
foreign import select
  "function select(selector) { \
  \  return function () { \
  \    return jQuery(selector); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .find(...)
foreign import find
  "function select(selector) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.find(selector); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .parent()
foreign import parent
  "function parent(ob) { \
  \  return function () { \
  \    return ob.parent(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery creation e.g. $('<div>')
foreign import create
  "function create(html) { \
  \  return function () { \
  \    return jQuery(html); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import setAttr
  "function setAttr(attr) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.attr(attr, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import attr
  "function attr(attrs) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.attr(attrs);\
  \    }; \
  \  }; \
  \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .css({ ... })
foreign import css
  "function css(props) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.css(props); \
  \    }; \
  \  }; \
  \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .hasClass(...)
foreign import hasClass
  "function hasClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.hasClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Boolean

-- .addClass(...)
foreign import addClass
  "function addClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.addClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .removeClass(...)
foreign import removeClass
  "function removeClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.removeClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import setProp
  "function setProp(p) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.prop(p, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import getProp
  "function getProp(p) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.prop(p);\
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Foreign

-- .append(...)
foreign import append
  "function append(ob1) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(ob1); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

foreign import appendAtIndex
  "function appendAtIndex(i) { \
  \  return function(ob1) { \
  \    return function(ob) { \
  \      return function () { \
  \        var children = ob.children();\
  \        if (children.length > 0) {\
  \          if (i <= 0) {\
  \             ob.prepend(ob1);\
  \          } else if (i >= children.length) {\
  \             ob.append(ob1);\
  \          } else {\
  \             ob1.insertBefore(jQuery(children[i]));\
  \          }\
  \          return ob;\
  \        } else {\
  \          return ob.append(ob1); \
  \        }\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .remove()
foreign import remove
  "function remove(ob) { \
  \  return function () { \
  \    return ob.remove(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .empty()
foreign import clear
  "function clear(ob) { \
  \  return function () { \
  \    return ob.empty(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .before(...)
foreign import before
  "function before(ob) { \
  \  return function(ob1) { \
  \    return function () { \
  \      return ob1.before(ob); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .append(...)
foreign import appendText
  "function appendText(s) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(s); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the document body
foreign import body
  "function body() { \
  \  return jQuery(document.body); \
  \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

-- Get the text content of an element
foreign import getText
  "function getText(ob) { \
  \  return function() { \
  \    return ob.text(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

-- Set the text content of an element
foreign import setText
  "function setText(text) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.text(text); \
  \    };\
  \  };\
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the value of a text field
foreign import getValue
  "function getValue(ob) { \
  \  return function() { \
  \    return ob.val(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) Foreign

-- Set the value of a text field
foreign import setValue
  "function setValue(val) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.val(val); \
  \    }; \
  \  }; \
  \}" :: forall eff a. a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on
  "function on(evt) { \
  \  return function(act) { \
  \    return function(ob) { \
  \      return function() { \
  \        return ob.on(evt, function(e) { \
  \          act(e)(jQuery(this))(); \
  \        }); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on'
  "function on$prime(evt) { \
  \  return function(sel) { \
  \    return function(act) { \
  \      return function(ob) { \
  \        return function() { \
  \          return ob.on(evt, sel, function(e) { \
  \            act(e)(jQuery(this))(); \
  \          }); \
  \        }; \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

foreign import preventDefault
  "function preventDefault(e) { \
  \  return function() { \
  \    e.preventDefault(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopPropagation
  "function stopPropagation(e) { \
  \  return function() { \
  \    e.stopPropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopImmediatePropagation
  "function stopImmediatePropagation(e) { \
  \  return function() { \
  \    e.stopImmediatePropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit


enable grouping on single selector

enable grouping on single selector

module Ifrit.Driver.MongoDB
  ( class Ingest
  , Pipeline
  , ingest
  , compile
  ) where

import Prelude

import Control.Apply(lift2)
import Control.Monad.State(evalStateT)
import Data.Argonaut.Core(Json, JAssoc, jsonEmptyObject, jsonZero, jsonNull, toArray)
import Data.Argonaut.Encode(encodeJson, extend, (:=), (~>))
import Data.Array(concat)
import Data.Decimal(toNumber)
import Data.Either(Either(..))
import Data.Foldable(foldr)
import Data.List(List)
import Data.List as List
import Data.Maybe(Maybe(..), maybe)
import Data.StrMap as StrMap
import Data.String(Pattern(..), split)
import Data.Tuple(Tuple(..))
import Partial.Unsafe(unsafePartial)

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

-- CLASS & TYPES
type Pipeline = Either String Json

class Ingest stage where
  ingest :: stage -> Pipeline

compile :: String -> Pipeline
compile query = do
  tokens <- evalStateT Lexer.tokenize { pos: 0, str: query }
  ast :: Parser.Statement <- evalStateT Parser.parse tokens
  ingest ast

-- UTILITIES
object :: Array (Tuple String Json) -> Json
object = StrMap.fromFoldable >>> encodeJson

singleton :: String -> Json -> Json
singleton k x = object [Tuple k x]

list :: Array Json -> Json
list = List.fromFoldable >>> encodeJson

defaultAlias :: String -> Maybe String -> String
defaultAlias default =
  maybe default (\x -> x)

extendM :: Either String JAssoc -> Either String Json -> Either String Json
extendM = lift2 extend

ingestBinary :: Lexer.Binary -> String
ingestBinary Lexer.Eq = "$eq"
ingestBinary Lexer.Neq = "$neq"
ingestBinary Lexer.Lt = "$lt"
ingestBinary Lexer.Gt = "$gt"

ingestProjection' :: Parser.Projection -> Either String JAssoc
ingestProjection' (Parser.Projection selector) =
  case selector of
    Parser.Selector s as ->
      Right $ defaultAlias s as := ("$" <> s)

    Parser.Function Lexer.Avg s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              sum = list
                [ encodeJson "$$value"
                , encodeJson $ "$" <> target
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonZero
                , "in" := (singleton "$add" sum)
                ]
              divide = list
                [ singleton "$reduce" reduce
                , singleton "$size" (encodeJson source)
                ]
          in
              Right $ alias := singleton "divide" divide
        _ ->
          Right $ defaultAlias s as := singleton "$avg" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Count s as ->
      case s of
        "*" ->
          Right $ defaultAlias "count" as := singleton "$sum" (encodeJson 1)
        _ ->
          let
              alias = defaultAlias s as
              count = list
                [ encodeJson "$$value"
                , encodeJson 1
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> s)
                , "initialValue" := jsonZero
                , "in" := (singleton "$add" count)
                ]
          in
              Right $ alias := singleton "$reduce" reduce

    Parser.Function Lexer.Max s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              or = list
                [ singleton "$eq" (list [ encodeJson "$$value", jsonNull ])
                , singleton "$gt" (list [ encodeJson $ "$" <> target, encodeJson "$$value" ])
                ]
              cond = object
                [ "if" := (singleton "$or" or)
                , "then" := (encodeJson $ "$" <> target)
                , "else" := (encodeJson "$$value")
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonNull
                , "in" := (singleton "$cond" cond)
                ]
          in
              Right $ alias := singleton "$reduce" reduce
        _ ->
          Right $ defaultAlias s as := singleton "$max" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Min s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              or = list
                [ singleton "$eq" (list [ encodeJson "$$value", jsonNull ])
                , singleton "$lt" (list [ encodeJson $ "$" <> target, encodeJson "$$value" ])
                ]
              cond = object
                [ "if" := (singleton "$or" or)
                , "then" := (encodeJson $ "$" <> target)
                , "else" := (encodeJson "$$value")
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonNull
                , "in" := (singleton "$cond" cond)
                ]
          in
              Right $ alias := singleton "$reduce" reduce
        _ ->
          Right $ defaultAlias s as := singleton "$min" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Sum s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              count = list
                [ encodeJson "$$value"
                , encodeJson $ "$$this." <> target
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonZero
                , "in" := (singleton "$add" count)
                ]
          in
              Right $ alias := singleton "$reduce" reduce
        _ ->
          Right $ defaultAlias s as := singleton "$sum" (encodeJson $ "$" <> s)

ingestAggregation' :: Parser.Aggregation -> Either String JAssoc
ingestAggregation' (Parser.Aggregation selector) =
  case selector of
    Parser.Selector s as ->
      Right $ defaultAlias s as := singleton "$push" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Avg s as ->
      Right $ defaultAlias s as := singleton "$avg" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Count s as ->
      Right $ defaultAlias "count" as := singleton "$sum" (encodeJson 1)

    Parser.Function Lexer.Max s as ->
      Right $ defaultAlias s as := singleton "$max" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Min s as ->
      Right $ defaultAlias s as := singleton "$min" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Sum s as ->
      Right $ defaultAlias s as := singleton "$sum" (encodeJson $ "$" <> s)

unwrapStatement :: Json -> Array Json
unwrapStatement json = unsafePartial $
  case (toArray json) of
    Just xs ->
      xs

maybeIngest :: forall a. Ingest a
  => (Json -> Array Json) -> Maybe a -> Either String (Array Json)
maybeIngest fn =
  maybe (pure []) (ingest >=> (\x -> pure $ fn x))

instance ingestStatement :: Ingest Parser.Statement where
  ingest (Parser.Select projections statement condition) = do
    projections' <- ingest projections
    statement' <- maybeIngest unwrapStatement statement
    condition' <- maybeIngest (\x -> [singleton "$match" x]) condition
    pure $ encodeJson $ concat
      [ statement'
      , condition'
      , [ singleton "$project" projections' ]
      ]

  ingest (Parser.Group index aggregations statement condition) = do
    aggregations' <- ingest aggregations
    statement' <- maybeIngest unwrapStatement statement
    condition' <- maybeIngest (\x -> [singleton "$match" x]) condition
    index' <- ingest index
    pure $ encodeJson $ concat
      [ statement'
      , condition'
      , [ singleton "$group" (("_id" := index') ~> aggregations') ]
      ]

instance ingestProjection :: Ingest (List Parser.Projection) where
  ingest xs =
    let
        projections = map ingestProjection' xs
        init = Right jsonEmptyObject
    in
        map encodeJson (foldr extendM init projections)

instance ingestAggregation :: Ingest (List Parser.Aggregation) where
  ingest xs =
    let
        aggregations= map ingestAggregation' xs
        init = Right jsonEmptyObject
    in
        map encodeJson (foldr extendM init aggregations)

instance ingestCondition :: Ingest Parser.Condition where
  ingest (Parser.Term t) = do
    t' <- ingest t
    pure t'

  ingest (Parser.Or t1 t2) = do
    t1' <- ingest t1
    t2' <- ingest t2
    pure $ singleton "$or" (list [t1', t2'])

instance ingestTerm :: Ingest Parser.Term where
  ingest (Parser.Factor f) = do
    f' <- ingest f
    pure f'

  ingest (Parser.And f1 f2) = do
    f1' <- ingest f1
    f2' <- ingest f2
    pure $ singleton "$and" (list [f1', f2'])

instance ingestFactor :: Ingest Parser.Factor where
  ingest (Parser.Operand o) = do
    o' <- ingest o
    pure o'

  ingest (Parser.Binary op o1 o2) = do
    o1' <- ingest o1
    o2' <- ingest o2
    let op' = ingestBinary op
    pure $ singleton op' (list [o1', o2'])

instance ingestOperand :: Ingest Parser.Operand where
  ingest (Parser.String s) =
    pure $ encodeJson s
  ingest (Parser.Boolean b) =
    pure $ encodeJson b
  ingest (Parser.Number d) =
    pure $ encodeJson $ toNumber d
  ingest (Parser.Field s) =
    pure $ encodeJson $ "$" <> s
  ingest (Parser.Null) =
    pure jsonNull
  ingest (Parser.Condition c) =
    ingest c

instance ingestIndex :: Ingest Parser.Index where
  ingest (Parser.IdxField s) =
    pure $ encodeJson $ "$" <> s
  ingest (Parser.IdxNull) =
    pure jsonNull

module Ifrit.Driver.MongoDB
  ( class Ingest
  , Pipeline
  , ingest
  , compile
  ) where

import Prelude

import Control.Apply(lift2)
import Control.Monad.State(evalStateT)
import Data.Argonaut.Core(Json, JAssoc, jsonEmptyObject, jsonZero, jsonNull, toArray)
import Data.Argonaut.Encode(encodeJson, extend, (:=), (~>))
import Data.Array(concat)
import Data.Decimal(toNumber)
import Data.Either(Either(..))
import Data.Foldable(foldr)
import Data.List(List)
import Data.List as List
import Data.Maybe(Maybe(..), maybe)
import Data.StrMap as StrMap
import Data.String(Pattern(..), split)
import Data.Tuple(Tuple(..))
import Partial.Unsafe(unsafePartial)

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

-- CLASS & TYPES
type Pipeline = Either String Json

class Ingest stage where
  ingest :: stage -> Pipeline

compile :: String -> Pipeline
compile query = do
  tokens <- evalStateT Lexer.tokenize { pos: 0, str: query }
  ast :: Parser.Statement <- evalStateT Parser.parse tokens
  ingest ast

-- UTILITIES
object :: Array (Tuple String Json) -> Json
object = StrMap.fromFoldable >>> encodeJson

singleton :: String -> Json -> Json
singleton k x = object [Tuple k x]

list :: Array Json -> Json
list = List.fromFoldable >>> encodeJson

defaultAlias :: String -> Maybe String -> String
defaultAlias default =
  maybe default (\x -> x)

extendM :: Either String JAssoc -> Either String Json -> Either String Json
extendM = lift2 extend

ingestBinary :: Lexer.Binary -> String
ingestBinary Lexer.Eq = "$eq"
ingestBinary Lexer.Neq = "$neq"
ingestBinary Lexer.Lt = "$lt"
ingestBinary Lexer.Gt = "$gt"

ingestProjection' :: Parser.Projection -> Either String JAssoc
ingestProjection' (Parser.Projection selector) =
  case selector of
    Parser.Selector s as ->
      Right $ defaultAlias s as := ("$" <> s)

    Parser.Function Lexer.Avg s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              sum = list
                [ encodeJson "$$value"
                , encodeJson $ "$" <> target
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonZero
                , "in" := (singleton "$add" sum)
                ]
              divide = list
                [ singleton "$reduce" reduce
                , singleton "$size" (encodeJson source)
                ]
          in
              Right $ alias := singleton "divide" divide
        _ ->
          Right $ defaultAlias s as := singleton "$avg" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Count s as ->
      case s of
        "*" ->
          Right $ defaultAlias "count" as := singleton "$sum" (encodeJson 1)
        _ ->
          let
              alias = defaultAlias s as
              count = list
                [ encodeJson "$$value"
                , encodeJson 1
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> s)
                , "initialValue" := jsonZero
                , "in" := (singleton "$add" count)
                ]
          in
              Right $ alias := singleton "$reduce" reduce

    Parser.Function Lexer.Max s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              or = list
                [ singleton "$eq" (list [ encodeJson "$$value", jsonNull ])
                , singleton "$gt" (list [ encodeJson $ "$" <> target, encodeJson "$$value" ])
                ]
              cond = object
                [ "if" := (singleton "$or" or)
                , "then" := (encodeJson $ "$" <> target)
                , "else" := (encodeJson "$$value")
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonNull
                , "in" := (singleton "$cond" cond)
                ]
          in
              Right $ alias := singleton "$reduce" reduce
        _ ->
          Right $ defaultAlias s as := singleton "$max" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Min s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              or = list
                [ singleton "$eq" (list [ encodeJson "$$value", jsonNull ])
                , singleton "$lt" (list [ encodeJson $ "$" <> target, encodeJson "$$value" ])
                ]
              cond = object
                [ "if" := (singleton "$or" or)
                , "then" := (encodeJson $ "$" <> target)
                , "else" := (encodeJson "$$value")
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonNull
                , "in" := (singleton "$cond" cond)
                ]
          in
              Right $ alias := singleton "$reduce" reduce
        _ ->
          Right $ defaultAlias s as := singleton "$min" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Sum s as ->
      case split (Pattern ".") s of
        [source, target] ->
          let
              alias = defaultAlias target as
              count = list
                [ encodeJson "$$value"
                , encodeJson $ "$$this." <> target
                ]
              reduce = object
                [ "input" := (encodeJson $ "$" <> source)
                , "initialValue" := jsonZero
                , "in" := (singleton "$add" count)
                ]
          in
              Right $ alias := singleton "$reduce" reduce
        _ ->
          Right $ defaultAlias s as := singleton "$sum" (encodeJson $ "$" <> s)

ingestAggregation' :: Parser.Aggregation -> Either String JAssoc
ingestAggregation' (Parser.Aggregation selector) =
  case selector of
    Parser.Selector s as ->
      Right $ defaultAlias s as := ("$" <> s)

    Parser.Function Lexer.Avg s as ->
      Right $ defaultAlias s as := singleton "$avg" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Count s as ->
      Right $ defaultAlias "count" as := singleton "$sum" (encodeJson 1)

    Parser.Function Lexer.Max s as ->
      Right $ defaultAlias s as := singleton "$max" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Min s as ->
      Right $ defaultAlias s as := singleton "$min" (encodeJson $ "$" <> s)

    Parser.Function Lexer.Sum s as ->
      Right $ defaultAlias s as := singleton "$sum" (encodeJson $ "$" <> s)

unwrapStatement :: Json -> Array Json
unwrapStatement json = unsafePartial $
  case (toArray json) of
    Just xs ->
      xs

maybeIngest :: forall a. Ingest a
  => (Json -> Array Json) -> Maybe a -> Either String (Array Json)
maybeIngest fn =
  maybe (pure []) (ingest >=> (\x -> pure $ fn x))

instance ingestStatement :: Ingest Parser.Statement where
  ingest (Parser.Select projections statement condition) = do
    projections' <- ingest projections
    statement' <- maybeIngest unwrapStatement statement
    condition' <- maybeIngest (\x -> [singleton "$match" x]) condition
    pure $ encodeJson $ concat
      [ statement'
      , condition'
      , [ singleton "$project" projections' ]
      ]

  ingest (Parser.Group index aggregations statement condition) = do
    aggregations' <- ingest aggregations
    statement' <- maybeIngest unwrapStatement statement
    condition' <- maybeIngest (\x -> [singleton "$match" x]) condition
    index' <- ingest index
    pure $ encodeJson $ concat
      [ statement'
      , condition'
      , [ singleton "$group" (("_id" := index') ~> aggregations') ]
      ]

instance ingestProjection :: Ingest (List Parser.Projection) where
  ingest xs =
    let
        projections = map ingestProjection' xs
        init = Right jsonEmptyObject
    in
        map encodeJson (foldr extendM init projections)

instance ingestAggregation :: Ingest (List Parser.Aggregation) where
  ingest xs =
    let
        aggregations= map ingestAggregation' xs
        init = Right jsonEmptyObject
    in
        map encodeJson (foldr extendM init aggregations)

instance ingestCondition :: Ingest Parser.Condition where
  ingest (Parser.Term t) = do
    t' <- ingest t
    pure t'

  ingest (Parser.Or t1 t2) = do
    t1' <- ingest t1
    t2' <- ingest t2
    pure $ singleton "$or" (list [t1', t2'])

instance ingestTerm :: Ingest Parser.Term where
  ingest (Parser.Factor f) = do
    f' <- ingest f
    pure f'

  ingest (Parser.And f1 f2) = do
    f1' <- ingest f1
    f2' <- ingest f2
    pure $ singleton "$and" (list [f1', f2'])

instance ingestFactor :: Ingest Parser.Factor where
  ingest (Parser.Operand o) = do
    o' <- ingest o
    pure o'

  ingest (Parser.Binary op o1 o2) = do
    o1' <- ingest o1
    o2' <- ingest o2
    let op' = ingestBinary op
    pure $ singleton op' (list [o1', o2'])

instance ingestOperand :: Ingest Parser.Operand where
  ingest (Parser.String s) =
    pure $ encodeJson s
  ingest (Parser.Boolean b) =
    pure $ encodeJson b
  ingest (Parser.Number d) =
    pure $ encodeJson $ toNumber d
  ingest (Parser.Field s) =
    pure $ encodeJson $ "$" <> s
  ingest (Parser.Null) =
    pure jsonNull
  ingest (Parser.Condition c) =
    ingest c

instance ingestIndex :: Ingest Parser.Index where
  ingest (Parser.IdxField s) =
    pure $ encodeJson $ "$" <> s
  ingest (Parser.IdxNull) =
    pure jsonNull


close code block

close code block

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeRight
  , takeWhile
  , drop
  , dropRight
  , dropWhile
  , slice
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
-- |
-- | ```purescript
-- | pursPattern = Pattern ".purs"
-- | --can be used like this:
-- | contains pursPattern "Test.purs"
-- |    == true
-- | ```
-- |
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
-- |
-- | ```purescript
-- | charAt 2 "Hello" == Just 'l'
-- | charAt 10 "Hello" == Nothing
-- | ```
-- |
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
-- |
-- | ```purescript
-- | singleton 'l' == "l"
-- | ```
-- |
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
-- | ```purescript
-- | charCodeAt 2 "5 €" == Just 0x20AC
-- | charCodeAt 10 "5 €" == Nothing
-- | ```
-- |
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

-- | Converts the string to a character, if the length of the string is
-- | exactly `1`.
-- |
-- | ```purescript
-- | toChar "l" == Just 'l'
-- | toChar "Hi" == Nothing -- since length is not 1
-- | ```
-- |
toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
-- |
-- | ```purescript
-- | null "" == true
-- | null "Hi" == false
-- | ```
-- |
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
-- |
-- | ```purescript
-- | uncons "" == Nothing
-- | uncons "Hello World" == Just { head: 'H', tail: "ello World" }
-- | ```
-- |
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
-- |
-- | ```purescript
-- | takeWhile (_ /= ':') "http://purescript.org" == "http"
-- | ```
-- |
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
-- |
-- | ```purescript
-- | dropWhile (_ /= '.') "Test.purs" == ".purs"
-- | ```
-- |
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Returns the substring at indices [begin, end).
-- | If either index is negative, it is normalised to `length s - index`,
-- | where `s` is the input string. An empty string is returned if either
-- | index is out of bounds or if `begin > end` after normalisation.
-- |
-- | ```purescript
-- | slice 0 1 "purescript" == "p"
-- | slice 3 6 "purescript" == "ecr"
-- | slice -4 -1 "purescript" == "rip"
-- | ```
foreign import slice :: Int -> Int -> String -> String

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- |
-- | ```purescript
-- | stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"
-- | stripPrefix (Pattern "http:") "https://purescript.org" == Nothing
-- | ```
-- |
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a `Just` value. Otherwise, return
-- | `Nothing`.
-- |
-- | ```purescript
-- | stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"
-- | stripSuffix (Pattern ".exe") "psc" == Nothing
-- | ```
-- |
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
-- |
-- | ```purescript
-- | fromCharArray ['H', 'e', 'l', 'l', 'o'] == "Hello"
-- | ```
-- |
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the pattern appears in the given string.
-- |
-- | ```purescript
-- | contains (Pattern "needle") "haystack with needle" == true
-- | contains (Pattern "needle") "haystack" == false
-- | ```
-- |
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | indexOf (Pattern "c") "abcdc" == Just 2
-- | indexOf (Pattern "c") "aaa" == Nothing
-- | ```
-- |
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the pattern in the
-- | given string, starting at the specified index. Returns `Nothing` if there is
-- | no match.
-- |
-- | ```purescript
-- | indexOf' (Pattern "a") 2 "ababa" == Just 2
-- | indexOf' (Pattern "a") 3 "ababa" == Just 4
-- | ```
-- |
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | lastIndexOf (Pattern "c") "abcdc" == Just 4
-- | lastIndexOf (Pattern "c") "aaa" == Nothing
-- | ```
-- |
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string, starting at the specified index
-- | and searching backwards towards the beginning of the string.
-- | Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | lastIndexOf' (Pattern "a") 1 "ababa" == Just 0
-- | lastIndexOf' (Pattern "a") 3 "ababa" == Just 2
-- | lastIndexOf' (Pattern "a") 4 "ababa" == Just 4
-- | ```
-- |
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
-- |
-- | ```purescript
-- | length "Hello World" == 11
-- | ```
-- |
foreign import length :: String -> Int

-- | Compare two strings in a locale-aware fashion. This is in contrast to
-- | the `Ord` instance on `String` which treats strings as arrays of code
-- | units:
-- |
-- | ```purescript
-- | "ä" `localeCompare` "b" == LT
-- | "ä" `compare` "b" == GT
-- | ```
-- |
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the pattern with the replacement string.
-- |
-- | ```purescript
-- | replace (Pattern "<=") (Replacement "≤") "a <= b <= c" == "a ≤ b <= c"
-- | ```
-- |
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the pattern with the replacement string.
-- |
-- | ```purescript
-- | replaceAll (Pattern "<=") (Replacement "≤") "a <= b <= c" == "a ≤ b ≤ c"
-- | ```
-- |
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
-- |
-- | ```purescript
-- | take 5 "Hello World" == "Hello"
-- | ```
-- |
foreign import take :: Int -> String -> String

-- | Returns the last `n` characters of the string.
-- |
-- | ```purescript
-- | takeRight 5 "Hello World" == "World"
-- | ```
-- |
takeRight :: Int -> String -> String
takeRight i s = drop (length s - i) s

-- | Returns the string without the first `n` characters.
-- |
-- | ```purescript
-- | drop 6 "Hello World" == "World"
-- | ```
-- |
foreign import drop :: Int -> String -> String

-- | Returns the string without the last `n` characters.
-- |
-- | ```purescript
-- | dropRight 6 "Hello World" == "Hello"
-- | ```
-- |
dropRight :: Int -> String -> String
dropRight i s = take (length s - i) s

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
-- |
-- | ```purescript
-- | count (_ /= ' ') "Hello World" == 5 -- since length "Hello" == 5
-- | ```
-- |
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- |
-- | ```purescript
-- | split (Pattern " ") "hello world" == ["hello", "world"]
-- | ```
-- |
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of a split at the given index, if the index is within bounds.
-- |
-- | ```purescript
-- | splitAt 2 "Hello World" == Just { before: "He", after: "llo World"}
-- | splitAt 10 "Hi" == Nothing
-- | ```
-- |
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe { before :: String, after :: String }

-- | Converts the string into an array of characters.
-- |
-- | ```purescript
-- | toCharArray "Hello☺\n" == ['H','e','l','l','o','☺','\n']
-- | ```
-- |
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
-- |
-- | ```purescript
-- | toLower "hElLo" == "hello"
-- | ```
-- |
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
-- |
-- | ```purescript
-- | toUpper "Hello" == "HELLO"
-- | ```
-- |
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
-- |
-- | ```purescript
-- | trim "   Hello  \n World\n\t    " == "Hello  \n World"
-- | ```
-- |
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
-- |
-- | ```purescript
-- | joinWith ", " ["apple", "banana", "orange"] == "apple, banana, orange"
-- | ```
-- |
foreign import joinWith :: String -> Array String -> String

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeRight
  , takeWhile
  , drop
  , dropRight
  , dropWhile
  , slice
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
-- |
-- | ```purescript
-- | pursPattern = Pattern ".purs"
-- | --can be used like this:
-- | contains pursPattern "Test.purs"
-- |    == true
-- | ```
-- |
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
-- |
-- | ```purescript
-- | charAt 2 "Hello" == Just 'l'
-- | charAt 10 "Hello" == Nothing
-- | ```
-- |
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
-- |
-- | ```purescript
-- | singleton 'l' == "l"
-- | ```
-- |
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
-- | ```purescript
-- | charCodeAt 2 "5 €" == Just 0x20AC
-- | charCodeAt 10 "5 €" == Nothing
-- | ```
-- |
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

-- | Converts the string to a character, if the length of the string is
-- | exactly `1`.
-- |
-- | ```purescript
-- | toChar "l" == Just 'l'
-- | toChar "Hi" == Nothing -- since length is not 1
-- | ```
-- |
toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
-- |
-- | ```purescript
-- | null "" == true
-- | null "Hi" == false
-- | ```
-- |
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
-- |
-- | ```purescript
-- | uncons "" == Nothing
-- | uncons "Hello World" == Just { head: 'H', tail: "ello World" }
-- | ```
-- |
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
-- |
-- | ```purescript
-- | takeWhile (_ /= ':') "http://purescript.org" == "http"
-- | ```
-- |
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
-- |
-- | ```purescript
-- | dropWhile (_ /= '.') "Test.purs" == ".purs"
-- | ```
-- |
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Returns the substring at indices [begin, end).
-- | If either index is negative, it is normalised to `length s - index`,
-- | where `s` is the input string. An empty string is returned if either
-- | index is out of bounds or if `begin > end` after normalisation.
-- |
-- | ```purescript
-- | slice 0 1 "purescript" == "p"
-- | slice 3 6 "purescript" == "ecr"
-- | slice -4 -1 "purescript" == "rip"
foreign import slice :: Int -> Int -> String -> String

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- |
-- | ```purescript
-- | stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"
-- | stripPrefix (Pattern "http:") "https://purescript.org" == Nothing
-- | ```
-- |
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a `Just` value. Otherwise, return
-- | `Nothing`.
-- |
-- | ```purescript
-- | stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"
-- | stripSuffix (Pattern ".exe") "psc" == Nothing
-- | ```
-- |
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
-- |
-- | ```purescript
-- | fromCharArray ['H', 'e', 'l', 'l', 'o'] == "Hello"
-- | ```
-- |
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the pattern appears in the given string.
-- |
-- | ```purescript
-- | contains (Pattern "needle") "haystack with needle" == true
-- | contains (Pattern "needle") "haystack" == false
-- | ```
-- |
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | indexOf (Pattern "c") "abcdc" == Just 2
-- | indexOf (Pattern "c") "aaa" == Nothing
-- | ```
-- |
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the pattern in the
-- | given string, starting at the specified index. Returns `Nothing` if there is
-- | no match.
-- |
-- | ```purescript
-- | indexOf' (Pattern "a") 2 "ababa" == Just 2
-- | indexOf' (Pattern "a") 3 "ababa" == Just 4
-- | ```
-- |
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | lastIndexOf (Pattern "c") "abcdc" == Just 4
-- | lastIndexOf (Pattern "c") "aaa" == Nothing
-- | ```
-- |
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string, starting at the specified index
-- | and searching backwards towards the beginning of the string.
-- | Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | lastIndexOf' (Pattern "a") 1 "ababa" == Just 0
-- | lastIndexOf' (Pattern "a") 3 "ababa" == Just 2
-- | lastIndexOf' (Pattern "a") 4 "ababa" == Just 4
-- | ```
-- |
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
-- |
-- | ```purescript
-- | length "Hello World" == 11
-- | ```
-- |
foreign import length :: String -> Int

-- | Compare two strings in a locale-aware fashion. This is in contrast to
-- | the `Ord` instance on `String` which treats strings as arrays of code
-- | units:
-- |
-- | ```purescript
-- | "ä" `localeCompare` "b" == LT
-- | "ä" `compare` "b" == GT
-- | ```
-- |
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the pattern with the replacement string.
-- |
-- | ```purescript
-- | replace (Pattern "<=") (Replacement "≤") "a <= b <= c" == "a ≤ b <= c"
-- | ```
-- |
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the pattern with the replacement string.
-- |
-- | ```purescript
-- | replaceAll (Pattern "<=") (Replacement "≤") "a <= b <= c" == "a ≤ b ≤ c"
-- | ```
-- |
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
-- |
-- | ```purescript
-- | take 5 "Hello World" == "Hello"
-- | ```
-- |
foreign import take :: Int -> String -> String

-- | Returns the last `n` characters of the string.
-- |
-- | ```purescript
-- | takeRight 5 "Hello World" == "World"
-- | ```
-- |
takeRight :: Int -> String -> String
takeRight i s = drop (length s - i) s

-- | Returns the string without the first `n` characters.
-- |
-- | ```purescript
-- | drop 6 "Hello World" == "World"
-- | ```
-- |
foreign import drop :: Int -> String -> String

-- | Returns the string without the last `n` characters.
-- |
-- | ```purescript
-- | dropRight 6 "Hello World" == "Hello"
-- | ```
-- |
dropRight :: Int -> String -> String
dropRight i s = take (length s - i) s

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
-- |
-- | ```purescript
-- | count (_ /= ' ') "Hello World" == 5 -- since length "Hello" == 5
-- | ```
-- |
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- |
-- | ```purescript
-- | split (Pattern " ") "hello world" == ["hello", "world"]
-- | ```
-- |
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of a split at the given index, if the index is within bounds.
-- |
-- | ```purescript
-- | splitAt 2 "Hello World" == Just { before: "He", after: "llo World"}
-- | splitAt 10 "Hi" == Nothing
-- | ```
-- |
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe { before :: String, after :: String }

-- | Converts the string into an array of characters.
-- |
-- | ```purescript
-- | toCharArray "Hello☺\n" == ['H','e','l','l','o','☺','\n']
-- | ```
-- |
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
-- |
-- | ```purescript
-- | toLower "hElLo" == "hello"
-- | ```
-- |
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
-- |
-- | ```purescript
-- | toUpper "Hello" == "HELLO"
-- | ```
-- |
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
-- |
-- | ```purescript
-- | trim "   Hello  \n World\n\t    " == "Hello  \n World"
-- | ```
-- |
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
-- |
-- | ```purescript
-- | joinWith ", " ["apple", "banana", "orange"] == "apple, banana, orange"
-- | ```
-- |
foreign import joinWith :: String -> Array String -> String


Update documentation for splitAt

Update documentation for splitAt

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix (Pattern "http:") "https://purescript.org" == Nothing`
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"`
-- | * `stripSuffix (Pattern ".exe") "psc" == Nothing`
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the first argument with the second argument.
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split (Pattern " ") "hello world" == ["hello", "world"]`
foreign import split :: Pattern -> String -> Array String

-- | Returns a string split into two substrings at the given index, where
-- | `before` includes all of the characters up to (but not including) the
-- | given index, and `after` is the rest of the string, from the given index
-- | on.
-- |
-- | Thus the length of `(splitAt i s).before` will equal either `i` or
-- | `length s`, if that is shorter. (Or if `i` is negative the length will be
-- | 0.)
-- |
-- | In code:
-- | ```purescript
-- | length (splitAt i s).before == min (max i 0) (length s)
-- | (splitAt i s).before <> (splitAt i s).after == s
-- | ```
foreign import splitAt :: Int -> String -> { before :: String, after :: String }

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix (Pattern "http:") "https://purescript.org" == Nothing`
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"`
-- | * `stripSuffix (Pattern ".exe") "psc" == Nothing`
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the first argument with the second argument.
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split (Pattern " ") "hello world" == ["hello", "world"]`
foreign import split :: Pattern -> String -> Array String

-- | Returns a string split into two substrings at the given index, where
-- | `before` includes all of the characters up to the given index, and `after`
-- | is the rest of the string, from the given index on.
foreign import splitAt :: Int -> String -> { before :: String, after :: String }

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String