Fix comment and tersen code in Value module

module Language.Docopt.Value (
    Value (..)
  , read
  , parse
  , isSameValueType
  , isBoolValue
  , isArrayValue
  , prettyPrintValue
  , intoArray
  ) where

import Prelude
import Data.Generic (class Generic)
import Data.Either (Either(), either)
import Data.Maybe.Unsafe (fromJust)
import Data.List (List(..), fromList, many, some)
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Text.Parsing.Parser (ParseError, runParser) as P
import Text.Parsing.Parser.Combinators (between, choice, try, sepBy1, option) as P
import Text.Parsing.Parser.String (noneOf, char, string, eof) as P
import Language.Docopt.Parser.Base (digit)
import Data.Array as A
import Data.Int (toNumber, fromString) as Int
import Data.String (fromCharArray)
import Global (readFloat)

data Value
  = StringValue String
  | BoolValue   Boolean
  | ArrayValue  (Array Value)
  | IntValue    Int
  | FloatValue  Number

derive instance genericValue :: Generic Value

instance showValue :: Show Value where
  show (StringValue s) = "StringValue " <> s
  show (BoolValue   b) = "BoolValue "   <> show b
  show (ArrayValue xs) = "ArrayValue "  <> show (show <$> xs)
  show (IntValue    x) = "IntValue "    <> show x
  show (FloatValue  x) = "FloatValue "  <> show x

instance eqValue :: Eq Value where
  eq (StringValue s) (StringValue s') = s  == s'
  eq (BoolValue   b) (BoolValue   b') = b  == b'
  eq (ArrayValue xs) (ArrayValue xs') = xs == xs'
  eq (FloatValue  x) (FloatValue  x') = x  == x'
  eq (IntValue    x) (IntValue    x') = x  == x'
  eq _               _                = false

isSameValueType :: Value -> Value -> Boolean
isSameValueType (StringValue _) (StringValue _) = true
isSameValueType (BoolValue   _) (BoolValue   _) = true
isSameValueType (ArrayValue  _) (ArrayValue  _) = true
isSameValueType (IntValue    _) (IntValue    _) = true
isSameValueType (FloatValue  _) (FloatValue  _) = true
isSameValueType _               _               = false

isBoolValue :: Value -> Boolean
isBoolValue (BoolValue _) = true
isBoolValue _             = false

isArrayValue :: Value -> Boolean
isArrayValue (ArrayValue _) = true
isArrayValue _              = false

isIntValue :: Value -> Boolean
isIntValue (IntValue _) = true
isIntValue _            = false

isFloatValue :: Value -> Boolean
isFloatValue (FloatValue _) = true
isFloatValue _              = false

prettyPrintValue :: Value -> String
prettyPrintValue (StringValue s) = s
prettyPrintValue (BoolValue   b) = show b
prettyPrintValue (ArrayValue xs) = show $ prettyPrintValue <$> xs
prettyPrintValue (IntValue    i) = show i
prettyPrintValue (FloatValue  f) = show f

intoArray (ArrayValue xs) = xs
intoArray v               = [v]

read :: String  -- ^ the input
     -> Boolean -- ^ allow splitting?
     -> Value
read s split = either (const $ StringValue s) id (parse s split)

-- | Parse a string into a value
-- | Values can be comma *AND* space separated:
-- |
-- | a  b  c -> [ a, b, c ]
-- | a, b, c -> [ a, b, c ]
-- | a  b, c -> [ a, b, c ]
-- | a, b  c -> [ a, b, c ]
-- |
parse :: String  -- ^ the input
      -> Boolean -- ^ allow splitting?
      -> Either P.ParseError Value
parse s split = P.runParser s $ if split then values else value <* P.eof

  where
    values = do
      vs <- P.sepBy1 inner $ P.choice [
        P.try $ many white *> (P.char ',') *> many white
      , some $ white
      ]

      pure $ case vs of
            Cons x Nil -> x
            _          -> ArrayValue (fromList vs)

    white = P.char ' ' <|> P.char '\n'

    inner = do
      P.try value <|> do StringValue <$> do
                                  fromCharArray <<< fromList <$> do
                                    many $ P.try (P.noneOf [',', ' ', '\n'])

    value = P.choice $ P.try <$> [ bool, number, quoted ]

    number = do
      si <- P.option 1 (P.char '-' *> pure (-1))
      xs <- fromCharArray <$> A.some digit
      P.choice [
        FloatValue <<< ((Int.toNumber si) * _) <<< readFloat <$> do
          xss <- do
            P.char '.'
            fromCharArray <$> A.some digit
          pure $ xs <> "." <> xss
      , pure $ IntValue $ si * (fromJust $ Int.fromString xs)
      ]

    bool = true' <|> false'
      where
        true' = do
          P.choice $ P.try <<< P.string <$> [ "true", "True", "TRUE" ]
          pure $ BoolValue true
        false' = do
          P.choice $ P.try <<< P.string <$> [ "false", "False", "FALSE" ]
          pure $ BoolValue false

    quoted = StringValue <$> do
      fromCharArray <<< fromList <$> do
        P.choice [
          P.between (P.char '"')  (P.char '"')  (many $ P.noneOf ['"'])
        , P.between (P.char '\'') (P.char '\'') (many $ P.noneOf ['\''])
        ]

module Language.Docopt.Value (
    Value (..)
  , read
  , parse
  , isSameValueType
  , isBoolValue
  , isArrayValue
  , prettyPrintValue
  , intoArray
  ) where

import Prelude
import Data.Generic (class Generic)
import Data.Either (Either(), either)
import Data.Maybe.Unsafe (fromJust)
import Data.List (List(..), fromList, many, some)
import Control.Apply ((*>))
import Control.Alt ((<|>))
import Text.Parsing.Parser (ParseError, runParser) as P
import Text.Parsing.Parser.Combinators (between, choice, try, sepBy1, option) as P
import Text.Parsing.Parser.String (noneOf, char, string, eof) as P
import Language.Docopt.Parser.Base (digit)
import Data.Array as A
import Data.Int (toNumber, fromString) as Int
import Data.String (fromCharArray)
import Global (readFloat)

data Value
  = StringValue String
  | BoolValue   Boolean
  | ArrayValue  (Array Value)
  | IntValue    Int
  | FloatValue  Number

derive instance genericValue :: Generic Value

instance showValue :: Show Value where
  show (StringValue s) = "StringValue " <> s
  show (BoolValue   b) = "BoolValue "   <> show b
  show (ArrayValue xs) = "ArrayValue "  <> show (show <$> xs)
  show (IntValue    x) = "IntValue "    <> show x
  show (FloatValue  x) = "FloatValue "  <> show x

instance eqValue :: Eq Value where
  eq (StringValue s) (StringValue s') = s  == s'
  eq (BoolValue   b) (BoolValue   b') = b  == b'
  eq (ArrayValue xs) (ArrayValue xs') = xs == xs'
  eq (FloatValue  x) (FloatValue  x') = x  == x'
  eq (IntValue    x) (IntValue    x') = x  == x'
  eq _               _                = false

isSameValueType :: Value -> Value -> Boolean
isSameValueType (StringValue _) (StringValue _) = true
isSameValueType (BoolValue   _) (BoolValue   _) = true
isSameValueType (ArrayValue  _) (ArrayValue  _) = true
isSameValueType (IntValue    _) (IntValue    _) = true
isSameValueType (FloatValue  _) (FloatValue  _) = true
isSameValueType _               _               = false

isBoolValue :: Value -> Boolean
isBoolValue (BoolValue _) = true
isBoolValue _             = false

isArrayValue :: Value -> Boolean
isArrayValue (ArrayValue _) = true
isArrayValue _              = false

isIntValue :: Value -> Boolean
isIntValue (IntValue _) = true
isIntValue _            = false

isFloatValue :: Value -> Boolean
isFloatValue (FloatValue _) = true
isFloatValue _              = false

prettyPrintValue :: Value -> String
prettyPrintValue (StringValue s) = s
prettyPrintValue (BoolValue   b) = show b
prettyPrintValue (ArrayValue xs) = show $ prettyPrintValue <$> xs
prettyPrintValue (IntValue    i) = show i
prettyPrintValue (FloatValue  f) = show f

intoArray (ArrayValue xs) = xs
intoArray v               = [v]

read :: String  -- ^ the input
     -> Boolean -- ^ allow splitting?
     -> Value
read s split = either (const $ StringValue s) id (parse s split)

-- | Parse a string into a value
-- | Values can be command *AND* space separated:
-- |
-- | a  b  c -> [ a, b, c ]
-- | a, b, c -> [ a, b, c ]
-- | a  b, c -> [ a, b, c ]
-- | a, b  c -> [ a, b, c ]
-- |
parse :: String  -- ^ the input
      -> Boolean -- ^ allow splitting?
      -> Either P.ParseError Value
parse s split = P.runParser s do
                  v <- if split then values
                                else value
                  P.eof
                  pure v

  where
    values = do
      vs <- P.sepBy1 inner $ P.choice [
        P.try $ many white *> (P.char ',') *> many white
      , some $ white
      ]

      pure $ case vs of
            Cons x Nil -> x
            _          -> ArrayValue (fromList vs)

    white = P.char ' ' <|> P.char '\n'

    inner = do
      P.try value <|> do StringValue <$> do
                                  fromCharArray <<< fromList <$> do
                                    many $ P.try (P.noneOf [',', ' ', '\n'])

    value = P.choice $ P.try <$> [ bool, number, quoted ]

    number = do
      si <- P.option 1 (P.char '-' *> pure (-1))
      xs <- fromCharArray <$> A.some digit
      P.choice [
        FloatValue <<< ((Int.toNumber si) * _) <<< readFloat <$> do
          xss <- do
            P.char '.'
            fromCharArray <$> A.some digit
          pure $ xs <> "." <> xss
      , pure $ IntValue $ si * (fromJust $ Int.fromString xs)
      ]

    bool = true' <|> false'
      where
        true' = do
          P.choice $ P.try <<< P.string <$> [ "true", "True", "TRUE" ]
          pure $ BoolValue true
        false' = do
          P.choice $ P.try <<< P.string <$> [ "false", "False", "FALSE" ]
          pure $ BoolValue false

    quoted = StringValue <$> do
      fromCharArray <<< fromList <$> do
        P.choice [
          P.between (P.char '"')  (P.char '"')  (many $ P.noneOf ['"'])
        , P.between (P.char '\'') (P.char '\'') (many $ P.noneOf ['\''])
        ]


Truncate history to 20 expressions when rendering

This avoids some nasty slowdown for long running sessions

module Components.Expressions
  ( component
  ) where

import Lambda.Prelude

import Data.Array as Array
import Lambda.Language.PrettyPrint (Rep, Doc, withRep)
import React.Basic (JSX)
import React.Basic.DOM as R

type Props =
  { history :: List (Doc String)
  , rep :: Rep
  }

component :: Props -> JSX
component {history, rep} = R.ul
  { className: "unstyled scroll-overflow"
  , children: truncate rep history
  }

truncate :: Rep -> List (Doc String) -> Array JSX
truncate rep = Array.fromFoldable <<< loop 20
 where
  loop :: Int -> List (Doc String) -> List JSX
  loop n = case _ of
    Nil -> Nil
    Cons t ts
      | n <= 0 -> item "…" : Nil
      | otherwise -> item (withRep rep t) : loop (n - 1) ts

  item :: String -> JSX
  item t = R.li
    { className: "expression"
    , children: [R.text t]
    }

module Components.Expressions
  ( component
  ) where

import Lambda.Prelude

import Lambda.Language.PrettyPrint (Rep, Doc, selectRep)
import React.Basic (JSX)
import React.Basic.DOM as R

type Props =
  { history :: Array (Doc String)
  , rep :: Rep
  }

component :: Props -> JSX
component {history, rep} =
  R.ul
    { className: "unstyled scroll-overflow"
    , children: map renderExpr history
    }
 where
  renderExpr expr =
    R.li
      { className: "expression"
      , children: [R.text $ selectRep expr rep]
      }


Minor syntactic reshuffling of type signatures.

module Database.AnyDB
  ( Query(..)
  , Connection()
  , DB()
  , ConnectionInfo()
  , ConnectionString()
  , mkConnectionString
  , connect
  , end
  , execute, execute_
  , query, query_
  , queryValue, queryValue_
  , queryOne, queryOne_
  , withConnection
  ) where

import Control.Alt
import Control.Monad.Eff
import Control.Monad.Trans
import Data.Either
import Data.Array
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Control.Monad.Aff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception(Error(), error)
import Control.Monad.Error.Class (throwError)
import Data.Traversable (sequence)

import Database.AnyDB.SqlValue

newtype Query a = Query String

foreign import data Connection :: *

foreign import data DB :: !

type ConnectionString = String

type ConnectionInfo =
  { host :: String
  , db :: String
  , port :: Number
  , user :: String
  , password :: String
  }

mkConnectionString :: ConnectionInfo -> ConnectionString
mkConnectionString ci =
    "postgres://"
  <> ci.user <> ":"
  <> ci.password <> "@"
  <> ci.host <> ":"
  <> show ci.port <> "/"
  <> ci.db

-- | Makes a connection to the database.
connect :: forall eff. ConnectionInfo -> Aff (db :: DB | eff) Connection
connect = connect' <<< mkConnectionString

-- | Runs a query and returns nothing.
execute :: forall eff a. Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) Unit
execute (Query sql) params con = void $ runQuery sql params con

-- | Runs a query and returns nothing
execute_ :: forall eff a. Query a -> Connection -> Aff (db :: DB | eff) Unit
execute_ (Query sql) con = void $ runQuery_ sql con

-- | Runs a query and returns all results.
query :: forall eff a. (IsForeign a) =>
         Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) [F a]
query (Query sql) params con = do
  rows <- runQuery sql params con
  pure $ read <$> rows

-- | Just like `query` but does not make any param replacement
query_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) [a]
query_ (Query sql) con = do
  rows <- runQuery_ sql con
  either liftError pure (sequence $ read <$> rows)

-- | Runs a query and returns the first row, if any
queryOne :: forall eff a. (IsForeign a) =>
            Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne (Query sql) params con = do
  rows <- runQuery sql params con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Just like `queryOne` but does not make any param replacement
queryOne_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne_ (Query sql) con = do
  rows <- runQuery_ sql con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Runs a query and returns a single value, if any.
queryValue :: forall eff a. (IsForeign a) =>
              Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue (Query sql) params con = do
  val <- runQueryValue sql params con
  pure $ either (const Nothing) Just (read val)

-- | Just like `queryValue` but does not make any param replacement
queryValue_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue_ (Query sql) con = do
  val <- runQueryValue_ sql con
  either liftError (pure <<< Just) $ read val

-- | Connects to the database, calls the provided function with the connection
-- | and returns the results.
withConnection :: forall eff a.
                  ConnectionInfo
               -> (Connection -> Aff (db :: DB | eff) a)
               -> Aff (db :: DB | eff) a
withConnection info p = do
  con <- connect info
  finally (p con) $ liftEff (end con)

liftError :: forall e a. ForeignError -> Aff e a
liftError err = throwError $ error (show err)

finally :: forall eff a. Aff eff a -> Aff eff Unit -> Aff eff a
finally a sequel = do
  res <- attempt a
  sequel
  either throwError pure res

foreign import connect' """
  function connect$prime(conString) {
    return function(success, error) {
      var anyDB = require('any-db');
      anyDB.createConnection(conString, function(err, con) {
        if (err) {
          error(err);
        } else {
          success(con);
        }
      });
    };
  }
  """ :: forall eff. ConnectionString -> Aff (db :: DB | eff) Connection

foreign import runQuery_ """
  function runQuery_(queryStr) {
    return function(con) {
      return function(success, error) {
        con.query(queryStr, function(err, result) {
          if (err) {
            error(err);
          } else {
            success(result.rows);
          }
        })
      };
    };
  }
  """ :: forall eff. String -> Connection -> Aff (db :: DB | eff) [Foreign]

foreign import runQuery """
  function runQuery(queryStr) {
    return function(params) {
      return function(con) {
        return function(success, error) {
          con.query(queryStr, params, function(err, result) {
            if (err) return error(err);
            success(result.rows);
          })
        };
      };
    }
  }
  """ :: forall eff. String -> [SqlValue] -> Connection -> Aff (db :: DB | eff) [Foreign]

foreign import runQueryValue_ """
  function runQueryValue_(queryStr) {
    return function(con) {
      return function(success, error) {
        con.query(queryStr, function(err, result) {
          if (err) return error(err);
          success(result.rows.length > 0 ? result.rows[0][result.fields[0].name] : undefined);
        })
      };
    };
  }
  """ :: forall eff. String -> Connection -> Aff (db :: DB | eff) Foreign

foreign import runQueryValue """
  function runQueryValue(queryStr) {
    return function(params) {
      return function(con) {
        return function(success, error) {
          con.query(queryStr, params, function(err, result) {
            if (err) return error(err);
            success(result.rows.length > 0 ? result.rows[0][result.fields[0].name] : undefined);
          })
        };
      };
    }
  }
  """ :: forall eff. String -> [SqlValue] -> Connection -> Aff (db :: DB | eff) Foreign

foreign import end """
  function end(con) {
    return function() {
      con.end();
    };
  }
  """ :: forall eff. Connection -> Eff (db :: DB | eff) Unit

module Database.AnyDB
  ( Query(..)
  , Connection()
  , DB()
  , ConnectionInfo()
  , ConnectionString()
  , mkConnectionString
  , connect
  , end
  , execute, execute_
  , query, query_
  , queryValue, queryValue_
  , queryOne, queryOne_
  , withConnection
  ) where

import Control.Alt
import Control.Monad.Eff
import Control.Monad.Trans
import Data.Either
import Data.Array
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Control.Monad.Aff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception(Error(), error)
import Control.Monad.Error.Class (throwError)
import Data.Traversable (sequence)

import Database.AnyDB.SqlValue

newtype Query a = Query String

foreign import data Connection :: *

foreign import data DB :: !

type ConnectionString = String

type ConnectionInfo =
  { host :: String
  , db :: String
  , port :: Number
  , user :: String
  , password :: String
  }

mkConnectionString :: ConnectionInfo -> ConnectionString
mkConnectionString ci =
    "postgres://"
  <> ci.user <> ":"
  <> ci.password <> "@"
  <> ci.host <> ":"
  <> show ci.port <> "/"
  <> ci.db

-- | Makes a connection to the database.
connect :: forall eff. ConnectionInfo -> Aff (db :: DB | eff) Connection
connect = connect' <<< mkConnectionString

-- | Runs a query and returns nothing.
execute :: forall eff a. Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) Unit
execute (Query sql) params con = void $ runQuery sql params con

-- | Runs a query and returns nothing
execute_ :: forall eff a. Query a -> Connection -> Aff (db :: DB | eff) Unit
execute_ (Query sql) con = void $ runQuery_ sql con

-- | Runs a query and returns all results.
query :: forall eff a
  . (IsForeign a)
  => Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) [F a]
query (Query sql) params con = do
  rows <- runQuery sql params con
  pure $ read <$> rows

-- | Just like `query` but does not make any param replacement
query_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) [a]
query_ (Query sql) con = do
  rows <- runQuery_ sql con
  either liftError pure (sequence $ read <$> rows)

-- | Runs a query and returns the first row, if any
queryOne :: forall eff a
  . (IsForeign a)
  => Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne (Query sql) params con = do
  rows <- runQuery sql params con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Just like `queryOne` but does not make any param replacement
queryOne_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne_ (Query sql) con = do
  rows <- runQuery_ sql con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Runs a query and returns a single value, if any.
queryValue :: forall eff a
  . (IsForeign a)
  => Query a -> [SqlValue] -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue (Query sql) params con = do
  val <- runQueryValue sql params con
  pure $ either (const Nothing) Just (read val)

-- | Just like `queryValue` but does not make any param replacement
queryValue_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue_ (Query sql) con = do
  val <- runQueryValue_ sql con
  either liftError (pure <<< Just) $ read val

-- | Connects to the database, calls the provided function with the connection
-- | and returns the results.
withConnection :: forall eff a
  . ConnectionInfo
  -> (Connection -> Aff (db :: DB | eff) a)
  -> Aff (db :: DB | eff) a
withConnection info p = do
  con <- connect info
  finally (p con) $ liftEff (end con)

liftError :: forall e a. ForeignError -> Aff e a
liftError err = throwError $ error (show err)

finally :: forall eff a. Aff eff a -> Aff eff Unit -> Aff eff a
finally a sequel = do
  res <- attempt a
  sequel
  either throwError pure res

foreign import connect' """
  function connect$prime(conString) {
    return function(success, error) {
      var anyDB = require('any-db');
      anyDB.createConnection(conString, function(err, con) {
        if (err) {
          error(err);
        } else {
          success(con);
        }
      });
    };
  }
  """ :: forall eff. ConnectionString -> Aff (db :: DB | eff) Connection

foreign import runQuery_ """
  function runQuery_(queryStr) {
    return function(con) {
      return function(success, error) {
        con.query(queryStr, function(err, result) {
          if (err) {
            error(err);
          } else {
            success(result.rows);
          }
        })
      };
    };
  }
  """ :: forall eff. String -> Connection -> Aff (db :: DB | eff) [Foreign]

foreign import runQuery """
  function runQuery(queryStr) {
    return function(params) {
      return function(con) {
        return function(success, error) {
          con.query(queryStr, params, function(err, result) {
            if (err) return error(err);
            success(result.rows);
          })
        };
      };
    }
  }
  """ :: forall eff. String -> [SqlValue] -> Connection -> Aff (db :: DB | eff) [Foreign]

foreign import runQueryValue_ """
  function runQueryValue_(queryStr) {
    return function(con) {
      return function(success, error) {
        con.query(queryStr, function(err, result) {
          if (err) return error(err);
          success(result.rows.length > 0 ? result.rows[0][result.fields[0].name] : undefined);
        })
      };
    };
  }
  """ :: forall eff. String -> Connection -> Aff (db :: DB | eff) Foreign

foreign import runQueryValue """
  function runQueryValue(queryStr) {
    return function(params) {
      return function(con) {
        return function(success, error) {
          con.query(queryStr, params, function(err, result) {
            if (err) return error(err);
            success(result.rows.length > 0 ? result.rows[0][result.fields[0].name] : undefined);
          })
        };
      };
    }
  }
  """ :: forall eff. String -> [SqlValue] -> Connection -> Aff (db :: DB | eff) Foreign

foreign import end """
  function end(con) {
    return function() {
      con.end();
    };
  }
  """ :: forall eff. Connection -> Eff (db :: DB | eff) Unit


Use string body instead of Json (#217)

Use string body instead of Json (#217)


Add second failing function

Add second failing function

module Hyper.HTML.DSLSpec where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Data.Identity (Identity)
import Data.Newtype (unwrap)
import Hyper.Core (HeadersClosed(HeadersClosed), class ResponseWriter, Middleware, HeadersOpen(HeadersOpen), ResponseEnded(ResponseEnded), Conn)
import Hyper.HTML.DSL (text, linkTo, html)
import Hyper.Method (Method(GET))
import Hyper.Response (headers, notFound)
import Hyper.Router (Path, notSupported, Unsupported, Supported, ResourceRecord, fallbackTo, handler, resource)
import Hyper.TestUtilities (TestResponseWriter(TestResponseWriter))
import Test.Spec (Spec, it, describe)
import Test.Spec.Assertions (shouldEqual)

about :: forall m req res rw c.
         (Monad m, ResponseWriter rw m) =>
         ResourceRecord
         m
         Supported
         Unsupported
         (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: HeadersClosed | res } c)
         (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: ResponseEnded | res } c)
about =
   { path: ["about"]
  , "GET": handler (\conn -> html (linkTo contact (text "Contact Me!")) conn)
  , "POST": notSupported
  }

contact :: forall m req res rw c.
           (Monad m, ResponseWriter rw m) =>
           ResourceRecord
           m
           Supported
           Unsupported
           (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: HeadersClosed | res } c)
           (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: ResponseEnded | res } c)
contact =
  { path: ["contact"]
  , "GET": handler (\conn -> html (linkTo about (text "About Me")) conn)
  , "POST": notSupported
  }

app :: forall m req res rw c.
  (Monad m, ResponseWriter rw m) =>
  Middleware
  m
  (Conn { path :: Path, method :: Method | req }
        { writer :: rw, state :: HeadersOpen | res }
        c)
  (Conn { path :: Path, method :: Method | req }
        { writer :: rw, state :: ResponseEnded | res }
        c)
app = headers [] >=> (fallbackTo (notFound) (resource about <|> resource contact))

-- But the rest is nice!

spec :: forall e. Spec (console :: CONSOLE | e) Unit
spec = do
  describe "Hyper.HTML.DSL" do
    it "can linkTo an existing route" do
      conn <- app
              { request: { method: GET
                         , path: ["about"]
                         }
              , response: { state: HeadersOpen
                          , writer: TestResponseWriter
                          }
              , components: {}
              }
      -- conn.response.body `shouldEqual` "Contact Me!"
      pure unit

    it "can linkTo another existing route" do
      conn <- app
              { request: { method: GET
                         , path: ["contact"]
                         }
              , response: { state: HeadersOpen
                          , writer: TestResponseWriter
                          }
              , components: {}
              }
      -- conn.response.body `shouldEqual` "About Me"
      pure unit

module Hyper.HTML.DSLSpec where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Data.Identity (Identity)
import Data.Newtype (unwrap)
import Hyper.Core (HeadersClosed(HeadersClosed), class ResponseWriter, Middleware, HeadersOpen(HeadersOpen), ResponseEnded(ResponseEnded), Conn)
import Hyper.HTML.DSL (text, linkTo, html)
import Hyper.Method (Method(GET))
import Hyper.Response (headers, notFound)
import Hyper.Router (Path, notSupported, Unsupported, Supported, ResourceRecord, fallbackTo, handler, resource)
import Hyper.TestUtilities (TestResponseWriter(TestResponseWriter))
import Test.Spec (Spec, it, describe)
import Test.Spec.Assertions (shouldEqual)

about :: forall m req res rw c.
         (Monad m, ResponseWriter rw m) =>
         ResourceRecord
         m
         Supported
         Unsupported
         (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: HeadersClosed | res } c)
         (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: ResponseEnded | res } c)
about = -- THIS IS WHERE I GET AN ERROR
   { path: ["about"]
  , "GET": handler (\conn -> html (linkTo contact (text "Contact Me!")) conn) -- SEEMINGLY CAUSED BY THIS
  , "POST": notSupported
  }

contact :: forall m req res rw c.
           (Monad m, ResponseWriter rw m) =>
           ResourceRecord
           m
           Supported
           Unsupported
           (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: HeadersClosed | res } c)
           (Conn { path :: Path, method :: Method | req } { writer :: rw, state :: ResponseEnded | res } c)
contact =
  { path: ["contact"]
  , "GET": handler (html (text "No"))
  --, "GET": handler (\conn -> html (linkTo about (text "About Me")) conn)
  , "POST": notSupported
  }

app :: forall m req res rw c.
  (Monad m, ResponseWriter rw m) =>
  Middleware
  m
  (Conn { path :: Path, method :: Method | req }
        { writer :: rw, state :: HeadersOpen | res }
        c)
  (Conn { path :: Path, method :: Method | req }
        { writer :: rw, state :: ResponseEnded | res }
        c)
app = headers [] >=> (fallbackTo (notFound) (resource about <|> resource contact))

-- But the rest is nice!

spec :: forall e. Spec (console :: CONSOLE | e) Unit
spec = do
  describe "Hyper.HTML.DSL" do
    it "can linkTo an existing route" do
      conn <- app
              { request: { method: GET
                         , path: ["about"]
                         }
              , response: { state: HeadersOpen
                          , writer: TestResponseWriter
                          }
              , components: {}
              }
      -- conn.response.body `shouldEqual` "Contact Me!"
      pure unit

    it "can linkTo another existing route" do
      conn <- app
              { request: { method: GET
                         , path: ["contact"]
                         }
              , response: { state: HeadersOpen
                          , writer: TestResponseWriter
                          }
              , components: {}
              }
      -- conn.response.body `shouldEqual` "About Me"
      pure unit


Update Resource Foreign / JSON instances for Quasar changes

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Model.Resource
  ( Resource(..)
  , _filePath
  , _name
  , _nameAnyPath
  , _path
  , _root
  , _tempFile
  , getPath
  , hiddenTopLevel
  , isDatabase
  , isDirectory
  , isFile
  , isHidden
  , isNotebook
  , isTempFile
  , mkDatabase
  , mkDirectory
  , mkFile
  , mkNotebook
  , newDatabase
  , newDirectory
  , newFile
  , newNotebook
  , parent
  , resourceDir
  , resourceName
  , resourcePath
  , resourceTag
  , root
  , sortResource
  ) where

import Prelude
import Config
import Control.Bind ((=<<))
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson)
import Data.Bifunctor (bimap, rmap)
import Data.Either
import Data.Either.Unsafe (fromRight)
import Data.Foreign (ForeignError(TypeMismatch))
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign.NullOrUndefined
import Data.Inject1
import Data.Maybe
import Data.Path.Pathy
import Data.Tuple
import Model.File.Sort (Sort(..))
import Model.Path
import Optic.Core
import Optic.Refractor.Prism (_Right)
import Optic.Types
import Utils

import qualified Data.String as S

-- TODO: should we have a constructor for views?
data Resource
  = File FilePath
  | Notebook DirPath
  | Directory DirPath
  | Database DirPath

instance showResource :: Show Resource where
  show r =
    case r of
      File fp -> "File " ++ show fp
      Notebook dp -> "Notebook " ++ show dp
      Directory dp -> "Directory " ++ show dp
      Database dp -> "Database " ++ show dp

_tempFile :: LensP Resource Resource
_tempFile = lens id \r s -> case r of
  File p ->
    if isTempFile r
    then s
    else r
  _ -> r

isTempFile :: Resource -> Boolean
isTempFile r =
  (takeDirExt <$> (dirName (resourceDir r))) == Just notebookExtension

_filePath :: PrismP Resource FilePath
_filePath = prism' File $ \s -> case s of
  File fp -> Just fp
  _ -> Nothing

isNotebook :: Resource -> Boolean
isNotebook (Notebook _) = true
isNotebook _ = false

isFile :: Resource -> Boolean
isFile (File _) = true
isFile _ = false

isDirectory :: Resource -> Boolean
isDirectory (Directory _) = true
isDirectory _ = false

isDatabase :: Resource -> Boolean
isDatabase (Database _) = true
isDatabase _ = false

resourceTag :: Resource -> String
resourceTag r = case r of
  File _ -> "file"
  Database _ -> "directory"
  Notebook _ -> "notebook"
  Directory _ -> "directory"

-- | TODO: we don't currently know when a file is really a view; should we?
resourceMountTypeTag :: Resource -> Maybe String
resourceMountTypeTag r = case r of
  Database _ -> Just "mongodb"
  _ -> Nothing

getPath :: Resource -> AnyPath
getPath r = case r of
  File p -> inj p
  Notebook p -> inj p
  Directory p -> inj p
  Database p -> inj p

isHidden :: Resource -> Boolean
isHidden r =
  either isHidden' isHidden' (getPath r)
  where
  isHidden' :: forall a b s. Path a b s -> Boolean
  isHidden' p = fromMaybe false do
    Tuple p' name <- peel p
    if "." == S.take 1 (nameOfFileOrDir name)
      then pure true
      else pure $ isHidden' p'

hiddenTopLevel :: Resource -> Boolean
hiddenTopLevel r = "." == S.take 1 (resourceName r)

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' p = maybe rootDir fst $ peel p

setDir :: AnyPath -> DirPath -> AnyPath
setDir ap d = bimap (setFile' d) (setDir' d) ap
  where
  setDir' :: DirPath -> DirPath -> DirPath
  setDir' d p =
    d </>
    (maybe currentDir (snd >>> nameOfFileOrDir >>> dir) $ peel p)

  setFile' :: DirPath -> FilePath -> FilePath
  setFile' d p =
    d </>
    (maybe (file "") (snd >>> nameOfFileOrDir >>> file) $ peel p)

renameAny :: (String -> String) -> AnyPath -> AnyPath
renameAny fn ap = bimap (renameFile $ liftFile fn) (renameDir $ liftDir fn) ap
  where
  liftFile fn (FileName a) = FileName $ fn a
  liftDir fn (DirName a) = DirName $ fn a

resourceName :: Resource -> String
resourceName = getPath >>> getNameStr

resourceDir :: Resource -> DirPath
resourceDir = getPath >>> getDir

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

root :: Resource
root = Directory rootDir

-- This is not real parent because it can't determine
-- is it a directory or mount
parent :: Resource -> Resource
parent = Directory <<< resourceDir

resourcePath :: Resource -> String
resourcePath r = either printPath printPath $ getPath r

newNotebook :: Resource
newNotebook = Notebook $ rootDir </> dir newNotebookName <./> notebookExtension

newFile :: Resource
newFile = File $ rootDir </> file newFileName

newDirectory :: Resource
newDirectory = Directory $ rootDir </> dir newFolderName

newDatabase :: Resource
newDatabase = Database $ rootDir </> dir newDatabaseName

mkNotebook :: AnyPath -> Resource
mkNotebook ap =
  either go (Notebook <<< (<./> notebookExtension)) ap
  where
  go :: FilePath -> Resource
  go p = maybe newNotebook id do
    Tuple pp dirOrFile <- peel p
    pure $ Notebook $
      (pp </> dir (nameOfFileOrDir dirOrFile) <./> notebookExtension)

mkFile :: AnyPath -> Resource
mkFile ap = either File go ap
  where
  go :: DirPath -> Resource
  go p = maybe newFile id do
    Tuple pp dirOrFile <- peel p
    pure $ File (pp </> file (nameOfFileOrDir dirOrFile))

mkDirectory :: AnyPath -> Resource
mkDirectory ap = either go Directory ap
  where
  go :: FilePath -> Resource
  go p = maybe newDirectory id do
    Tuple pp dirOrFile <- peel p
    pure $ Directory (pp </> dir (nameOfFileOrDir dirOrFile))

mkDatabase :: AnyPath -> Resource
mkDatabase ap = either go Database ap
  where
  go :: FilePath -> Resource
  go p = maybe newDatabase id do
    Tuple pp dirOrFile <- peel p
    pure $ Database (pp </> dir (nameOfFileOrDir dirOrFile))

setPath :: Resource -> AnyPath -> Resource
setPath (Notebook _) p = mkNotebook p
setPath (File _) p = mkFile p
setPath (Database _) p = mkDatabase p
setPath (Directory _) p = mkDirectory p

setName :: Resource -> String -> Resource
setName r name =
  setPath r ((renameAny (const name) (getPath r)))

_path :: LensP Resource AnyPath
_path = lens getPath setPath

_nameAnyPath :: LensP AnyPath String
_nameAnyPath = lens getNameStr (\p x -> renameAny (const x) p)

_name :: LensP Resource String
_name = _path ..  _nameAnyPath

_rootAnyPath :: LensP AnyPath DirPath
_rootAnyPath = lens getDir setDir

_root :: LensP Resource DirPath
_root = _path .. _rootAnyPath

instance resourceEq :: Eq Resource where
  eq (File p) (File p') = p == p'
  eq (Notebook p) (Notebook p') = p == p'
  eq (Directory p) (Directory p') = p == p'
  eq (Database p) (Database p') = p == p'
  eq _ _ = false

instance resourceIsForeign :: IsForeign Resource where
  read f = do
    name <- readProp "name" f
    ty <- readProp "type" f
    mountType <- runNullOrUndefined <$> readProp "mount" f
    template <- case ty of
      "directory" ->
        case mountType of
          Just "mongodb" -> pure newDatabase
          _ ->
            pure $
              if endsWith notebookExtension name
                then newNotebook
                else newDirectory
      "file" -> pure newFile
      _ -> Left $ TypeMismatch "resource" "string"
    pure $ setName template name

instance encodeJsonResource :: EncodeJson Resource where
  encodeJson res =
    "type" := resourceTag res
    ~> "path" := resourcePath res
    ~> maybe
        jsonEmptyObject
        (\t -> "mount" := t ~> jsonEmptyObject)
        (resourceMountTypeTag res)

instance decodeJsonResource :: DecodeJson Resource where
  decodeJson json = do
    obj <- decodeJson json
    resType <- obj .? "type"
    path <- obj .? "path"
    let mountType = Data.StrMap.lookup "mount" obj >>= decodeJson >>> either (const Nothing) pure
    case resType of
      -- type inference bug prevents use of a generic `parsePath` which accepts `parseAbsFile` or `parseAbsDir` as an argument
      "file" -> maybe (Left $ "Invalid file path") (Right <<< File) $ (rootDir </>) <$> (sandbox rootDir =<< parseAbsFile path)
      "notebook" -> parseDirPath "notebook" Notebook path
      "directory" ->
        case mountType of
          Just "mongodb" -> parseDirPath "mount" Database path
          _ -> parseDirPath "directory" Directory path
      _ -> Left "Unrecognized resource type"
    where
    parseDirPath :: String -> (DirPath -> Resource) -> String -> Either String Resource
    parseDirPath ty ctor s = maybe (Left $ "Invalid " ++ ty ++ " path") (Right <<< ctor) $ (rootDir </>) <$> (sandbox rootDir =<< parseAbsDir s)

sortResource :: (Resource -> String) -> Sort -> Resource -> Resource -> Ordering
sortResource project direction a b =
  if (isHidden a) && (not $ isHidden b) then GT else
    if (isHidden b) && (not $ isHidden a) then LT else
      case direction of
        Asc -> compare (project a) (project b)
        Desc -> compare (project b) (project a)

instance resourceOrd :: Ord Resource where
  compare = sortResource resourcePath Asc

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Model.Resource
  ( Resource(..)
  , _filePath
  , _name
  , _nameAnyPath
  , _path
  , _root
  , _tempFile
  , getPath
  , hiddenTopLevel
  , isDatabase
  , isDirectory
  , isFile
  , isHidden
  , isNotebook
  , isTempFile
  , mkDatabase
  , mkDirectory
  , mkFile
  , mkNotebook
  , newDatabase
  , newDirectory
  , newFile
  , newNotebook
  , parent
  , resourceDir
  , resourceName
  , resourcePath
  , resourceTag
  , root
  , sortResource
  ) where

import Prelude
import Config
import Control.Bind ((=<<))
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson)
import Data.Bifunctor (bimap, rmap)
import Data.Either
import Data.Either.Unsafe (fromRight)
import Data.Foreign (ForeignError(TypeMismatch))
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Inject1
import Data.Maybe
import Data.Path.Pathy
import Data.Tuple
import Model.File.Sort (Sort(..))
import Model.Path
import Optic.Core
import Optic.Refractor.Prism (_Right)
import Optic.Types
import Utils

import qualified Data.String as S

data Resource
  = File FilePath
  | Notebook DirPath
  | Directory DirPath
  | Database DirPath

instance showResource :: Show Resource where
  show r =
    case r of
      File fp -> "File " ++ show fp
      Notebook dp -> "Notebook " ++ show dp
      Directory dp -> "Directory " ++ show dp
      Database dp -> "Database " ++ show dp

_tempFile :: LensP Resource Resource
_tempFile = lens id \r s -> case r of
  File p ->
    if isTempFile r
    then s
    else r
  _ -> r

isTempFile :: Resource -> Boolean
isTempFile r =
  (takeDirExt <$> (dirName (resourceDir r))) == Just notebookExtension

_filePath :: PrismP Resource FilePath
_filePath = prism' File $ \s -> case s of
  File fp -> Just fp
  _ -> Nothing

isNotebook :: Resource -> Boolean
isNotebook (Notebook _) = true
isNotebook _ = false

isFile :: Resource -> Boolean
isFile (File _) = true
isFile _ = false

isDirectory :: Resource -> Boolean
isDirectory (Directory _) = true
isDirectory _ = false

isDatabase :: Resource -> Boolean
isDatabase (Database _) = true
isDatabase _ = false

resourceTag :: Resource -> String
resourceTag r = case r of
  File _ -> "file"
  Database _ -> "mount"
  Notebook _ -> "notebook"
  Directory _ -> "directory"

getPath :: Resource -> AnyPath
getPath r = case r of
  File p -> inj p
  Notebook p -> inj p
  Directory p -> inj p
  Database p -> inj p

isHidden :: Resource -> Boolean
isHidden r =
  either isHidden' isHidden' (getPath r)
  where
  isHidden' :: forall a b s. Path a b s -> Boolean
  isHidden' p = fromMaybe false do
    Tuple p' name <- peel p
    if "." == S.take 1 (nameOfFileOrDir name)
      then pure true
      else pure $ isHidden' p'

hiddenTopLevel :: Resource -> Boolean
hiddenTopLevel r = "." == S.take 1 (resourceName r)

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' p = maybe rootDir fst $ peel p

setDir :: AnyPath -> DirPath -> AnyPath
setDir ap d = bimap (setFile' d) (setDir' d) ap
  where
  setDir' :: DirPath -> DirPath -> DirPath
  setDir' d p =
    d </>
    (maybe currentDir (snd >>> nameOfFileOrDir >>> dir) $ peel p)

  setFile' :: DirPath -> FilePath -> FilePath
  setFile' d p =
    d </>
    (maybe (file "") (snd >>> nameOfFileOrDir >>> file) $ peel p)

renameAny :: (String -> String) -> AnyPath -> AnyPath
renameAny fn ap = bimap (renameFile $ liftFile fn) (renameDir $ liftDir fn) ap
  where
  liftFile fn (FileName a) = FileName $ fn a
  liftDir fn (DirName a) = DirName $ fn a

resourceName :: Resource -> String
resourceName = getPath >>> getNameStr

resourceDir :: Resource -> DirPath
resourceDir = getPath >>> getDir

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

root :: Resource
root = Directory rootDir

-- This is not real parent because it can't determine
-- is it a directory or mount
parent :: Resource -> Resource
parent = Directory <<< resourceDir

resourcePath :: Resource -> String
resourcePath r = either printPath printPath $ getPath r

newNotebook :: Resource
newNotebook = Notebook $ rootDir </> dir newNotebookName <./> notebookExtension

newFile :: Resource
newFile = File $ rootDir </> file newFileName

newDirectory :: Resource
newDirectory = Directory $ rootDir </> dir newFolderName

newDatabase :: Resource
newDatabase = Database $ rootDir </> dir newDatabaseName

mkNotebook :: AnyPath -> Resource
mkNotebook ap =
  either go (Notebook <<< (<./> notebookExtension)) ap
  where
  go :: FilePath -> Resource
  go p = maybe newNotebook id do
    Tuple pp dirOrFile <- peel p
    pure $ Notebook $
      (pp </> dir (nameOfFileOrDir dirOrFile) <./> notebookExtension)

mkFile :: AnyPath -> Resource
mkFile ap = either File go ap
  where
  go :: DirPath -> Resource
  go p = maybe newFile id do
    Tuple pp dirOrFile <- peel p
    pure $ File (pp </> file (nameOfFileOrDir dirOrFile))

mkDirectory :: AnyPath -> Resource
mkDirectory ap = either go Directory ap
  where
  go :: FilePath -> Resource
  go p = maybe newDirectory id do
    Tuple pp dirOrFile <- peel p
    pure $ Directory (pp </> dir (nameOfFileOrDir dirOrFile))

mkDatabase :: AnyPath -> Resource
mkDatabase ap = either go Database ap
  where
  go :: FilePath -> Resource
  go p = maybe newDatabase id do
    Tuple pp dirOrFile <- peel p
    pure $ Database (pp </> dir (nameOfFileOrDir dirOrFile))

setPath :: Resource -> AnyPath -> Resource
setPath (Notebook _) p = mkNotebook p
setPath (File _) p = mkFile p
setPath (Database _) p = mkDatabase p
setPath (Directory _) p = mkDirectory p

setName :: Resource -> String -> Resource
setName r name =
  setPath r ((renameAny (const name) (getPath r)))

_path :: LensP Resource AnyPath
_path = lens getPath setPath

_nameAnyPath :: LensP AnyPath String
_nameAnyPath = lens getNameStr (\p x -> renameAny (const x) p)

_name :: LensP Resource String
_name = _path ..  _nameAnyPath

_rootAnyPath :: LensP AnyPath DirPath
_rootAnyPath = lens getDir setDir

_root :: LensP Resource DirPath
_root = _path .. _rootAnyPath

instance resourceEq :: Eq Resource where
  eq (File p) (File p') = p == p'
  eq (Notebook p) (Notebook p') = p == p'
  eq (Directory p) (Directory p') = p == p'
  eq (Database p) (Database p') = p == p'
  eq _ _ = false

instance resourceIsForeign :: IsForeign Resource where
  read f = do
    name <- readProp "name" f
    ty <- readProp "type" f
    template <- case ty of
      "mount" -> pure newDatabase
      "directory" -> pure $ if endsWith notebookExtension name
                            then newNotebook
                            else newDirectory
      "file" -> pure newFile
      _ -> Left $ TypeMismatch "resource" "string"
    pure $ setName template name

instance encodeJsonResource :: EncodeJson Resource where
  encodeJson res = "type" := resourceTag res
                ~> "path" := resourcePath res
                ~> jsonEmptyObject

instance decodeJsonResource :: DecodeJson Resource where
  decodeJson json = do
    obj <- decodeJson json
    resType <- obj .? "type"
    path <- obj .? "path"
    case resType of
      -- type inference bug prevents use of a generic `parsePath` which accepts `parseAbsFile` or `parseAbsDir` as an argument
      "file" -> maybe (Left $ "Invalid file path") (Right <<< File) $ (rootDir </>) <$> (sandbox rootDir =<< parseAbsFile path)
      "notebook" -> parseDirPath "notebook" Notebook path
      "directory" -> parseDirPath "directory" Directory path
      "mount" -> parseDirPath "mount" Database path
      _ -> Left "Unrecognized resource type"
    where
    parseDirPath :: String -> (DirPath -> Resource) -> String -> Either String Resource
    parseDirPath ty ctor s = maybe (Left $ "Invalid " ++ ty ++ " path") (Right <<< ctor) $ (rootDir </>) <$> (sandbox rootDir =<< parseAbsDir s)

sortResource :: (Resource -> String) -> Sort -> Resource -> Resource -> Ordering
sortResource project direction a b =
  if (isHidden a) && (not $ isHidden b) then GT else
    if (isHidden b) && (not $ isHidden a) then LT else
      case direction of
        Asc -> compare (project a) (project b)
        Desc -> compare (project b) (project a)

instance resourceOrd :: Ord Resource where
  compare = sortResource resourcePath Asc


Use Eq for elemIndex equality

Use Eq for elemIndex equality

module Data.Array
  ( (!!)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import findIndex
  "function findIndex (f) {\
  \  return function (arr) {\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import findLastIndex
  "function findLastIndex (f) {\
  \  return function (arr) {\
  \    for (var i = arr.length - 1; i >= 0; i--) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

elemIndex :: forall a. (Eq a) => a -> [a] -> Number
elemIndex x = findIndex ((==) x)

elemLastIndex :: forall a. (Eq a) => a -> [a] -> Number
elemLastIndex x = findLastIndex ((==) x)

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = append

module Data.Array
  ( (!!)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import findIndex
  "function findIndex (f) {\
  \  return function (arr) {\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import findLastIndex
  "function findLastIndex (f) {\
  \  return function (arr) {\
  \    for (var i = arr.length - 1; i >= 0; i--) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import elemIndex
  "function elemIndex (e) {\
  \  return function (l) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import elemLastIndex
  "function elemLastIndex (e) {\
  \  return function (l) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = append


Parse list of 'Def's instead of single one

module Parser where

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

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

import AST

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

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

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

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

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

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

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

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

parseExpr :: String -> Either String Expr
parseExpr = parse expr

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

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

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

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

opList :: [Parser String Op]
opList =
  [ opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string "*")     Mul
  , opP (string "`div`") Div
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "&&")    And
  , opP (string "||")    Or
  ]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

parseDefs :: String -> Either String [Definition]
parseDefs = parse defs

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

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

module Parser where

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

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

import AST

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

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

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

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

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

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

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

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

parseExpr :: String -> Either String Expr
parseExpr = parse expr

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

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

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

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

opList :: [Parser String Op]
opList =
  [ opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string "*")     Mul
  , opP (string "`div`") Div
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "&&")    And
  , opP (string "||")    Or
  ]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

parseDef :: String -> Either String Definition
parseDef = parse def

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


Undo change ...

Undo change ...

module Data.Vector
  ( Vec
  , empty
  , cons, (+>)
  , snoc
  , uncons
  , singleton
  , replicate
  , length
  , lengthT
  , toArray
  , toUnfoldable
  , index, (!!)
  , concat
  , updateAt
  , modifyAt
  , insertAt
  , deleteAt
  , head
  , last
  , tail
  , init
  , insert
  , insertBy
  , slice
  , take
  , drop
  , zip
  , zipWith
  , unzip
  , sort
  , sortBy
  , reverse
  , mapWithIndex
  , updateAtI
  , updateAt_
  , runIntIndexed
  ) where

import Prelude
import Data.Array as Array
import Data.Foldable (foldl, foldr, foldMap, class Foldable)
import Data.Maybe (fromJust)
import Data.Tuple (Tuple(Tuple))
import Data.Typelevel.Num (class Min, class Sub, class LtEq, class Pred, class Lt)
import Data.Typelevel.Num.Ops (class Add, class Succ)
import Data.Typelevel.Num.Reps (D1, D0)
import Data.Typelevel.Num.Sets (class Nat, class Pos, reifyInt, toInt)
import Data.Typelevel.Undefined (undefined)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

-- | `Vec s a` is an array with a fixed size `s` defined at the type level.
newtype Vec s a = Vec (Array a)

-- | An empty vector.
empty :: forall a. Vec D0 a
empty = Vec []

-- | Prepend a value to the front of a vector, creating a vector of size `Succ s`.
cons :: forall s s' a. (Nat s, Pos s', Succ s s') => a -> Vec s a -> Vec s' a
cons x (Vec xs) = Vec $ Array.cons x xs
infixr 5 cons as +>

-- | Append a value to the end of a vector, creating a vector of size `Succ s`.
snoc :: forall s s' a. (Nat s, Pos s', Succ s s') => a -> Vec s a -> Vec s' a
snoc x (Vec xs) = Vec $ Array.snoc xs x

-- | Get the head and the tail of a non-empty vector.
uncons :: forall s1 s2 a. (Pos s1, Pred s1 s2) => Vec s1 a -> { head :: a, tail :: Vec s2 a }
uncons (Vec v) = case unsafePartial $ fromJust $ Array.uncons v of
  { head: h, tail: t } -> { head: h, tail: Vec t }

-- | Construct a vector containing only a single element.
singleton :: forall a. a -> Vec D1 a
singleton x = x +> empty

-- | Construct a vector of a given length containing the same element repeated.
replicate :: forall s a. (Nat s) => s -> a -> Vec s a
replicate s a = Vec $ Array.replicate (toInt s) a

-- | Get the length of a vector as an integer.
length :: forall s a. Nat s => Vec s a -> Int
length _ = toInt (undefined :: s)

-- | Get the length of a vector as a type level number.
lengthT :: forall s a. Nat s => Vec s a -> s
lengthT _ = undefined

-- | Convert a vector into an array. This simply unwraps the underlying array, so it has no runtime cost.
toArray :: forall s a. Nat s => Vec s a -> Array a
toArray (Vec xs) = xs

-- | Convert a vector into any `Unfoldable`.
toUnfoldable :: forall f s a. (Unfoldable f, Nat s) => Vec s a -> f a
toUnfoldable (Vec v) = Array.toUnfoldable v

-- | Get the element at a given index inside a vector. Index out of bounds errors
-- | are caught at compile time.
-- |
-- | Example:
-- |
-- |     myVector = 1 +> 2 +> 3 +> 4 +> empty
-- |     value = index myVector d2
-- |     -- value == 3
-- |     value = index myVector d4
-- |     -- out of bounds so does not type check
index :: forall i s a. (Nat i, Nat s, Lt i s) => Vec s a -> i -> a
index (Vec xs) i = unsafePartial $ Array.unsafeIndex xs $ toInt i
infixl 8 index as !!

-- | Concatenate two vectors together.
concat :: forall s1 s2 s3 a. (Nat s1, Nat s2, Add s1 s2 s3) => Vec s1 a -> Vec s2 a -> Vec s3 a
concat (Vec xs1) (Vec xs2) = Vec $ Array.concat [xs1, xs2]

-- | Update a vector with a given value inserted at a given index.
updateAt :: forall i s a. (Nat i, Nat s, Lt i s) => i -> a -> Vec s a -> Vec s a
updateAt i v (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.updateAt (toInt i) v xs
updateAt_ :: forall i s a. (Nat i, Nat s) => i -> a -> Vec s a -> Vec s a
updateAt_ i v (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.updateAt (toInt i) v xs

-- | Update a vector at a given index using a function.
modifyAt :: forall i s a. (Nat i, Nat s, Lt i s) => i -> (a -> a) -> Vec s a -> Vec s a
modifyAt i f (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.modifyAt (toInt i) f xs

-- | Insert a value at a given index inside a vector, returning a vector
-- | that is one element larger.
insertAt :: forall i s1 s2 a. (Nat i, Nat s1, Nat s2, Lt i s1, Succ s1 s2) => i -> a -> Vec s1 a -> Vec s2 a
insertAt i a (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.insertAt (toInt i) a xs

-- | Remove an element at a given index inside a vector, returning a vector
-- | that is one element smaller.
deleteAt :: forall i s1 s2 a. (Nat i, Pos s1, Nat s2, Lt i s1, Pred s1 s2) => i -> Vec s1 a -> Vec s2 a
deleteAt i (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.deleteAt (toInt i) xs

-- | Get the head of a non-empty vector.
head :: forall s a. (Pos s) => Vec s a -> a
head (Vec xs) = unsafePartial $ fromJust $ Array.head xs

-- | Get the last element of a non-empty vector.
last :: forall s a. (Pos s) => Vec s a -> a
last (Vec xs) = unsafePartial $ fromJust $ Array.last xs

-- | Get the tail of a non-empty vector.
tail :: forall s1 s2 a. (Pos s1, Nat s2, Pred s1 s2) => Vec s1 a -> Vec s2 a
tail (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.tail xs

-- | Get all but the last element of a non-empty vector.
init :: forall s1 s2 a. (Pos s1, Nat s2, Pred s1 s2) => Vec s1 a -> Vec s2 a
init (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.init xs

-- | Insert an element into a sorted vector.
insert :: forall s1 s2 a. (Nat s1, Succ s1 s2, Ord a) => a -> Vec s1 a -> Vec s2 a
insert a (Vec v) = Vec $ Array.insert a v

-- | Insert an element into a sorted vector using an ordering function.
insertBy :: forall s1 s2 a. (Nat s1, Succ s1 s2) => (a -> a -> Ordering) -> a -> Vec s1 a -> Vec s2 a
insertBy f a (Vec v) = Vec $ Array.insertBy f a v

-- | Get a sub-vector from index `i1` up to but not including index `i2`.
slice :: forall i1 i2 s1 s2 a. (Nat i1, Nat i2, Nat s1, LtEq i1 s1, LtEq i2 s1, LtEq i1 i2, Sub i2 i1 s2) => i1 -> i2 -> Vec s1 a -> Vec s2 a
slice i1 i2 (Vec xs) = Vec $ Array.slice (toInt i1) (toInt i2) xs

-- | Get the first `c` elements from a vector.
take :: forall c s a. (Nat c, Nat s, LtEq c s) => c -> Vec s a -> Vec c a
take c (Vec xs) = Vec $ Array.take (toInt c) xs

-- | Drop the first `c` elements from a vector.
drop :: forall c s1 s2 a. (Nat c, Nat s1, LtEq c s1, Sub s1 c s2) => c -> Vec s1 a -> Vec s2 a
drop c (Vec xs) = Vec $ Array.drop (toInt c) xs

-- | Zip two vectors together into a vector of tuples.
-- |
-- | The new vector will be the size of the smallest input vector, and
-- | superfluous elements from the other will be discarded.
zip :: forall s1 s2 s3 a b. (Nat s1, Nat s2, Min s1 s2 s3) => Vec s1 a -> Vec s2 b -> Vec s3 (Tuple a b)
zip (Vec v1) (Vec v2) = Vec $ Array.zip v1 v2

-- | Zip two vectors together using a combining function.
-- |
-- | The new vector will be the size of the smallest input vector, and
-- | superfluous elements from the other will be discarded.
zipWith :: forall s1 s2 s3 a b c. (Nat s1, Nat s2, Min s1 s2 s3) => (a -> b -> c) -> Vec s1 a -> Vec s2 b -> Vec s3 c
zipWith f (Vec v1) (Vec v2) = Vec $ Array.zipWith f v1 v2

-- | Unzip a vector of tuples into a tuple of vectors.
unzip :: forall s a b. (Nat s) => Vec s (Tuple a b) -> Tuple (Vec s a) (Vec s b)
unzip (Vec v) = case Array.unzip v of
  (Tuple v1 v2) -> Tuple (Vec v1) (Vec v2)

-- | Sort a vector of `Ord`s.
sort :: forall s a. (Nat s, Ord a) => Vec s a -> Vec s a
sort (Vec v) = Vec $ Array.sort v

-- | Sort a vector using an ordering function.
sortBy :: forall s a. (Nat s) => (a -> a -> Ordering) -> Vec s a -> Vec s a
sortBy f (Vec v) = Vec $ Array.sortBy f v

-- | Reverse a vector.
reverse :: forall s a. (Nat s) => Vec s a -> Vec s a
reverse (Vec v) = Vec $ Array.reverse v

-- | Map the vector, supplying the index to the mapping function.
mapWithIndex :: forall s a b. (Nat s) => (Int -> a -> b) -> Vec s a -> Vec s b
mapWithIndex mapper (Vec array) = Vec $ Array.mapWithIndex mapper array

-- | Run a function that takes a type-valued index with a int-valued index
--runIntIndexed :: forall i s1 s2 a. (Nat i, Nat s1, Nat s2, Lt i s1) => (i -> a -> Vec s1 a -> Vec s2 a) -> Int -> a -> Vec s1 a -> Vec s2 a
--runIntIndexed :: forall s1 a. (Nat s1) => (forall i. (Nat i, Lt i s1) => i -> a -> Vec s1 a -> Vec s1 a) -> Int -> a -> Vec s1 a -> Vec s1 a
runIntIndexed :: forall s1 a x. (Nat s1) => (forall i. (Nat i) => i -> x -> Vec s1 a -> Vec s1 a) -> Int -> x -> Vec s1 a -> Vec s1 a
runIntIndexed f i x v
    | i >= toInt (undefined :: s1) = unsafeCrashWith "runIntIndexed: index out of bounds"
    | otherwise =
        let
            f' = f--(unsafeCoerce f) :: forall i. (Nat i) => i -> a -> Vec s1 a -> Vec s1 a--(unsafeCoerce (flip f x) :: forall j s z. (Nat j, Nat s, Nat z) => j -> Vec s a -> Vec z a)
        in
            reifyInt i f' x v

--updateAtI :: forall s a. (Nat s, Lt s i) => Int -> a -> Vec s a -> Vec s a
updateAtI = runIntIndexed updateAt
deleteAtI = flip (runIntIndexed (flip $ const deleteAt)) unit

instance functorVec :: (Nat s) => Functor (Vec s) where
  map f (Vec xs) = Vec $ map f xs

instance applyVec :: (Nat s) => Apply (Vec s) where
  apply (Vec a) (Vec b) = Vec $ apply a b

instance applicativeVec :: Applicative (Vec D1) where
  pure a = singleton a

instance foldableVec :: (Nat s) => Foldable (Vec s) where
  foldMap f (Vec xs) = foldMap f xs
  foldr f i (Vec xs) = foldr f i xs
  foldl f i (Vec xs) = foldl f i xs

instance eqVec :: (Nat s, Eq a) => Eq (Vec s a) where
  eq (Vec v1) (Vec v2) = v1 == v2

instance showVec :: (Nat s, Show a) => Show (Vec s a) where
  show (Vec v) = show v

module Data.Vector
  ( Vec
  , empty
  , cons, (+>)
  , snoc
  , uncons
  , singleton
  , replicate
  , length
  , lengthT
  , toArray
  , toUnfoldable
  , index, (!!)
  , concat
  , updateAt
  , modifyAt
  , insertAt
  , deleteAt
  , head
  , last
  , tail
  , init
  , insert
  , insertBy
  , slice
  , take
  , drop
  , zip
  , zipWith
  , unzip
  , sort
  , sortBy
  , reverse
  , mapWithIndex
  , updateAtI
  , updateAt_
  , runIntIndexed
  ) where

import Prelude
import Data.Array as Array
import Data.Foldable (foldl, foldr, foldMap, class Foldable)
import Data.Maybe (fromJust)
import Data.Tuple (Tuple(Tuple))
import Data.Typelevel.Num (class Min, class Sub, class LtEq, class Pred, class Lt)
import Data.Typelevel.Num.Ops (class Add, class Succ)
import Data.Typelevel.Num.Reps (D1, D0)
import Data.Typelevel.Num.Sets (class Nat, class Pos, reifyInt, toInt)
import Data.Typelevel.Undefined (undefined)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafeCrashWith, unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

-- | `Vec s a` is an array with a fixed size `s` defined at the type level.
newtype Vec s a = Vec (Array a)

-- | An empty vector.
empty :: forall a. Vec D0 a
empty = Vec []

-- | Prepend a value to the front of a vector, creating a vector of size `Succ s`.
cons :: forall s s' a. (Nat s, Pos s', Succ s s') => a -> Vec s a -> Vec s' a
cons x (Vec xs) = Vec $ Array.cons x xs
infixr 5 cons as +>

-- | Append a value to the end of a vector, creating a vector of size `Succ s`.
snoc :: forall s s' a. (Nat s, Pos s', Succ s s') => a -> Vec s a -> Vec s' a
snoc x (Vec xs) = Vec $ Array.snoc xs x

-- | Get the head and the tail of a non-empty vector.
uncons :: forall s1 s2 a. (Pos s1, Pred s1 s2) => Vec s1 a -> { head :: a, tail :: Vec s2 a }
uncons (Vec v) = case unsafePartial $ fromJust $ Array.uncons v of
  { head: h, tail: t } -> { head: h, tail: Vec t }

-- | Construct a vector containing only a single element.
singleton :: forall a. a -> Vec D1 a
singleton x = x +> empty

-- | Construct a vector of a given length containing the same element repeated.
replicate :: forall s a. (Nat s) => s -> a -> Vec s a
replicate s a = Vec $ Array.replicate (toInt s) a

-- | Get the length of a vector as an integer.
length :: forall s a. Nat s => Vec s a -> Int
length _ = toInt (undefined :: s)

-- | Get the length of a vector as a type level number.
lengthT :: forall s a. Nat s => Vec s a -> s
lengthT _ = undefined

-- | Convert a vector into an array. This simply unwraps the underlying array, so it has no runtime cost.
toArray :: forall s a. Nat s => Vec s a -> Array a
toArray (Vec xs) = xs

-- | Convert a vector into any `Unfoldable`.
toUnfoldable :: forall f s a. (Unfoldable f, Nat s) => Vec s a -> f a
toUnfoldable (Vec v) = Array.toUnfoldable v

-- | Get the element at a given index inside a vector. Index out of bounds errors
-- | are caught at compile time.
-- |
-- | Example:
-- |
-- |     myVector = 1 +> 2 +> 3 +> 4 +> empty
-- |     value = index myVector d2
-- |     -- value == 3
-- |     value = index myVector d4
-- |     -- out of bounds so does not type check
index :: forall i s a. (Nat i, Nat s, Lt i s) => Vec s a -> i -> a
index (Vec xs) i = unsafePartial $ Array.unsafeIndex xs $ toInt i
infixl 8 index as !!

-- | Concatenate two vectors together.
concat :: forall s1 s2 s3 a. (Nat s1, Nat s2, Add s1 s2 s3) => Vec s1 a -> Vec s2 a -> Vec s3 a
concat (Vec xs1) (Vec xs2) = Vec $ Array.concat [xs1, xs2]

-- | Update a vector with a given value inserted at a given index.
updateAt :: forall i s a. (Nat i, Nat s, Lt i s) => i -> a -> Vec s a -> Vec s a
updateAt i v (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.updateAt (toInt i) v xs
updateAt_ :: forall i s a. (Nat i, Nat s) => i -> a -> Vec s a -> Vec s a
updateAt_ i v (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.updateAt (toInt i) v xs

-- | Update a vector at a given index using a function.
modifyAt :: forall i s a. (Nat i, Nat s, Lt i s) => i -> (a -> a) -> Vec s a -> Vec s a
modifyAt i f (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.modifyAt (toInt i) f xs

-- | Insert a value at a given index inside a vector, returning a vector
-- | that is one element larger.
insertAt :: forall i s1 s2 a. (Nat i, Nat s1, Nat s2, Lt i s1, Succ s1 s2) => i -> a -> Vec s1 a -> Vec s2 a
insertAt i a (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.insertAt (toInt i) a xs

-- | Remove an element at a given index inside a vector, returning a vector
-- | that is one element smaller.
deleteAt :: forall i s1 s2 a. (Nat i, Pos s1, Nat s2, Lt i s1, Pred s1 s2) => i -> Vec s1 a -> Vec s2 a
deleteAt i (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.deleteAt (toInt i) xs

-- | Get the head of a non-empty vector.
head :: forall s a. (Pos s) => Vec s a -> a
head (Vec xs) = unsafePartial $ fromJust $ Array.head xs

-- | Get the last element of a non-empty vector.
last :: forall s a. (Pos s) => Vec s a -> a
last (Vec xs) = unsafePartial $ fromJust $ Array.last xs

-- | Get the tail of a non-empty vector.
tail :: forall s1 s2 a. (Pos s1, Nat s2, Pred s1 s2) => Vec s1 a -> Vec s2 a
tail (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.tail xs

-- | Get all but the last element of a non-empty vector.
init :: forall s1 s2 a. (Pos s1, Nat s2, Pred s1 s2) => Vec s1 a -> Vec s2 a
init (Vec xs) = Vec $ unsafePartial $ fromJust $ Array.init xs

-- | Insert an element into a sorted vector.
insert :: forall s1 s2 a. (Nat s1, Succ s1 s2, Ord a) => a -> Vec s1 a -> Vec s2 a
insert a (Vec v) = Vec $ Array.insert a v

-- | Insert an element into a sorted vector using an ordering function.
insertBy :: forall s1 s2 a. (Nat s1, Succ s1 s2) => (a -> a -> Ordering) -> a -> Vec s1 a -> Vec s2 a
insertBy f a (Vec v) = Vec $ Array.insertBy f a v

-- | Get a sub-vector from index `i1` up to but not including index `i2`.
slice :: forall i1 i2 s1 s2 a. (Nat i1, Nat i2, Nat s1, LtEq i1 s1, LtEq i2 s1, LtEq i1 i2, Sub i2 i1 s2) => i1 -> i2 -> Vec s1 a -> Vec s2 a
slice i1 i2 (Vec xs) = Vec $ Array.slice (toInt i1) (toInt i2) xs

-- | Get the first `c` elements from a vector.
take :: forall c s a. (Nat c, Nat s, LtEq c s) => c -> Vec s a -> Vec c a
take c (Vec xs) = Vec $ Array.take (toInt c) xs

-- | Drop the first `c` elements from a vector.
drop :: forall c s1 s2 a. (Nat c, Nat s1, LtEq c s1, Sub s1 c s2) => c -> Vec s1 a -> Vec s2 a
drop c (Vec xs) = Vec $ Array.drop (toInt c) xs

-- | Zip two vectors together into a vector of tuples.
-- |
-- | The new vector will be the size of the smallest input vector, and
-- | superfluous elements from the other will be discarded.
zip :: forall s1 s2 s3 a b. (Nat s1, Nat s2, Min s1 s2 s3) => Vec s1 a -> Vec s2 b -> Vec s3 (Tuple a b)
zip (Vec v1) (Vec v2) = Vec $ Array.zip v1 v2

-- | Zip two vectors together using a combining function.
-- |
-- | The new vector will be the size of the smallest input vector, and
-- | superfluous elements from the other will be discarded.
zipWith :: forall s1 s2 s3 a b c. (Nat s1, Nat s2, Min s1 s2 s3) => (a -> b -> c) -> Vec s1 a -> Vec s2 b -> Vec s3 c
zipWith f (Vec v1) (Vec v2) = Vec $ Array.zipWith f v1 v2

-- | Unzip a vector of tuples into a tuple of vectors.
unzip :: forall s a b. (Nat s) => Vec s (Tuple a b) -> Tuple (Vec s a) (Vec s b)
unzip (Vec v) = case Array.unzip v of
  (Tuple v1 v2) -> Tuple (Vec v1) (Vec v2)

-- | Sort a vector of `Ord`s.
sort :: forall s a. (Nat s, Ord a) => Vec s a -> Vec s a
sort (Vec v) = Vec $ Array.sort v

-- | Sort a vector using an ordering function.
sortBy :: forall s a. (Nat s) => (a -> a -> Ordering) -> Vec s a -> Vec s a
sortBy f (Vec v) = Vec $ Array.sortBy f v

-- | Reverse a vector.
reverse :: forall s a. (Nat s) => Vec s a -> Vec s a
reverse (Vec v) = Vec $ Array.reverse v

-- | Map the vector, supplying the index to the mapping function.
mapWithIndex :: forall s a b. (Nat s) => (Int -> a -> b) -> Vec s a -> Vec s b
mapWithIndex mapper (Vec array) = Vec $ Array.mapWithIndex mapper array

-- | Run a function that takes a type-valued index with a int-valued index
--runIntIndexed :: forall i s1 s2 a. (Nat i, Nat s1, Nat s2, Lt i s1) => (i -> a -> Vec s1 a -> Vec s2 a) -> Int -> a -> Vec s1 a -> Vec s2 a
--runIntIndexed :: forall s1 a. (Nat s1) => (forall i. (Nat i, Lt i s1) => i -> a -> Vec s1 a -> Vec s1 a) -> Int -> a -> Vec s1 a -> Vec s1 a
runIntIndexed :: forall s1 a x. (Nat s1) => (forall i. (Nat i) => x -> i -> Vec s1 a -> Vec s1 a) -> x -> Int -> Vec s1 a -> Vec s1 a
runIntIndexed f x i v
    | i >= toInt (undefined :: s1) = unsafeCrashWith "runIntIndexed: index out of bounds"
    | otherwise =
        let
            f' = f--(unsafeCoerce f) :: forall i. (Nat i) => i -> a -> Vec s1 a -> Vec s1 a--(unsafeCoerce (flip f x) :: forall j s z. (Nat j, Nat s, Nat z) => j -> Vec s a -> Vec z a)
        in
            reifyInt i (\j -> f' x j v)

--updateAtI :: forall s a. (Nat s, Lt s i) => Int -> a -> Vec s a -> Vec s a
updateAtI = runIntIndexed (flip updateAt)
deleteAtI = runIntIndexed (const deleteAt) unit

instance functorVec :: (Nat s) => Functor (Vec s) where
  map f (Vec xs) = Vec $ map f xs

instance applyVec :: (Nat s) => Apply (Vec s) where
  apply (Vec a) (Vec b) = Vec $ apply a b

instance applicativeVec :: Applicative (Vec D1) where
  pure a = singleton a

instance foldableVec :: (Nat s) => Foldable (Vec s) where
  foldMap f (Vec xs) = foldMap f xs
  foldr f i (Vec xs) = foldr f i xs
  foldl f i (Vec xs) = foldl f i xs

instance eqVec :: (Nat s, Eq a) => Eq (Vec s a) where
  eq (Vec v1) (Vec v2) = v1 == v2

instance showVec :: (Nat s, Show a) => Show (Vec s a) where
  show (Vec v) = show v