Use nocache param on GETs

Use nocache param on GETs

{-
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 Api.Common where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Ref (REF())
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((~>), (:=))
import Data.Argonaut.Core (Json(), JAssoc(), jsonEmptyObject)
import Data.Date (nowEpochMilliseconds)
import Data.Foldable (foldl)
import Data.Int (fromNumber, toNumber)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Path.Pathy
import Data.Time (Milliseconds(..))
import Model.Path (AnyPath())
import Network.HTTP.Affjax (Affjax(), AJAX(), URL(), AffjaxRequest(), defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable)
import Network.HTTP.Method (Method(..))
import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))
import qualified Data.String as S

successStatus :: StatusCode
successStatus = StatusCode 200

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF | e)

-- | A version of `affjax` with our retry policy.
slamjax :: forall e a b. (Requestable a, Respondable b) => AffjaxRequest a -> Affjax (RetryEffects e) b
slamjax = retry defaultRetryPolicy affjax

retryGet :: forall e a fd. (Respondable a) => Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryGet u = do
  nocache <- liftEff $ nowEpochMilliseconds
  let url = printPath u
      symbol = if S.contains "?" url then "&" else "?"
  slamjax $ defaultRequest { url = url ++ symbol ++ "nocache=" ++ pretty nocache }
  where
  pretty (Milliseconds ms) =
    let s = show ms
    in fromMaybe s (S.stripSuffix ".0" s)

retryDelete :: forall e a fd. (Respondable a) => Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryDelete u = slamjax $ defaultRequest { url = printPath u, method = DELETE }

retryPost :: forall e a b fd. (Requestable a, Respondable b) => Path Abs fd Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c = slamjax $ defaultRequest { method = POST, url = printPath u, content = Just c }

retryPut :: forall e a b fd. (Requestable a, Respondable b) => Path Abs fd Sandboxed-> a -> Affjax (RetryEffects e) b
retryPut u c = slamjax $ defaultRequest { method = PUT, url = printPath u, content = Just c }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- affjax
  if not $ succeeded res.status
    then throwError $ error msg
    else pure res.response

reqHeadersToJSON :: Array RequestHeader -> Json
reqHeadersToJSON = foldl go jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj

{-
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 Api.Common where

import Prelude
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Ref (REF())
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((~>), (:=))
import Data.Argonaut.Core (Json(), JAssoc(), jsonEmptyObject)
import Data.Int (fromNumber, toNumber)
import Data.Foldable (foldl)
import Data.Path.Pathy
import Model.Path (AnyPath())
import Data.Maybe (Maybe(..))
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable)
import Network.HTTP.Affjax (Affjax(), AJAX(), URL(), AffjaxRequest(), defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Method (Method(..))

import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))

successStatus :: StatusCode
successStatus = StatusCode 200

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF | e)

-- | A version of `affjax` with our retry policy.
slamjax :: forall e a b. (Requestable a, Respondable b) => AffjaxRequest a -> Affjax (RetryEffects e) b
slamjax = retry defaultRetryPolicy affjax

retryGet :: forall e a fd. (Respondable a) => Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryGet u = slamjax $ defaultRequest { url = printPath u }

retryDelete :: forall e a fd. (Respondable a) => Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryDelete u = slamjax $ defaultRequest { url = printPath u, method = DELETE }

retryPost :: forall e a b fd. (Requestable a, Respondable b) => Path Abs fd Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c = slamjax $ defaultRequest { method = POST, url = printPath u, content = Just c }

retryPut :: forall e a b fd. (Requestable a, Respondable b) => Path Abs fd Sandboxed-> a -> Affjax (RetryEffects e) b
retryPut u c = slamjax $ defaultRequest { method = PUT, url = printPath u, content = Just c }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- affjax
  if not $ succeeded res.status
    then throwError $ error msg
    else pure res.response

reqHeadersToJSON :: Array RequestHeader -> Json
reqHeadersToJSON = foldl go jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj


Add some additional common character generators

module Data.Char.Gen where

import Prelude

import Control.Monad.Gen (class MonadGen, chooseInt, oneOf)
import Data.Char as C
import Data.NonEmpty ((:|))

-- | Generates a character of the Unicode basic multilingual plain.
genUnicodeChar :: forall m. MonadGen m => m Char
genUnicodeChar = C.fromCharCode <$> chooseInt 0 65536

-- | Generates a character in the ASCII character set, excluding control codes.
genAsciiChar :: forall m. MonadGen m => m Char
genAsciiChar = C.fromCharCode <$> chooseInt 32 127

-- | Generates a character in the ASCII character set.
genAsciiChar' :: forall m. MonadGen m => m Char
genAsciiChar' = C.fromCharCode <$> chooseInt 0 127

-- | Generates a character that is a numeric digit.
genDigitChar :: forall m. MonadGen m => m Char
genDigitChar = C.fromCharCode <$> chooseInt 48 57

-- | Generates a character from the basic latin alphabet.
genAlpha :: forall m. MonadGen m => m Char
genAlpha = oneOf (genAlphaLowercase :| [genAlphaUppercase])

-- | Generates a lowercase character from the basic latin alphabet.
genAlphaLowercase :: forall m. MonadGen m => m Char
genAlphaLowercase = C.fromCharCode <$> chooseInt 97 122

-- | Generates an uppercase character from the basic latin alphabet.
genAlphaUppercase :: forall m. MonadGen m => m Char
genAlphaUppercase = C.fromCharCode <$> chooseInt 65 90

module Data.Char.Gen where

import Prelude

import Control.Monad.Gen (class MonadGen, chooseInt)
import Data.Char as C

-- | Generates a character of the Unicode basic multilingual plain.
genUnicodeChar :: forall m. MonadGen m => m Char
genUnicodeChar = C.fromCharCode <$> chooseInt 0 65536

-- | Generates a character in the ASCII character set, excluding control codes.
genAsciiChar :: forall m. MonadGen m => m Char
genAsciiChar = C.fromCharCode <$> chooseInt 32 127

-- | Generates a character in the ASCII character set.
genAsciiChar' :: forall m. MonadGen m => m Char
genAsciiChar' = C.fromCharCode <$> chooseInt 0 127

-- | Generates a character that is a numeric digit.
genDigitChar :: forall m. MonadGen m => m Char
genDigitChar = C.fromCharCode <$> chooseInt 48 57


Add missing import

Add missing import

module Node.FS.Async
  ( Callback (..)
  , rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Eff.Exception
import Data.Date
import Data.Either
import Data.Function
import Data.Maybe
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())

foreign import data Nullable :: * -> *

type JSCallback a = Fn2 (Nullable Error) a Unit

foreign import handleCallbackImpl
  "function handleCallbackImpl(left, right, f) {\
  \  return function(err, value) {\
  \    if (err) f(left(err))();\
  \    else f(right(value))();\
  \  };\
  \}" :: forall eff a. Fn3 (Error -> Either Error a)
                           (a -> Either Error a)
                           (Callback eff a)
                           (JSCallback a)

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a
handleCallback cb = runFn3 handleCallbackImpl Left Right cb

foreign import fs "var fs = require('fs');" ::
  { rename :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , truncate :: Fn3 FilePath Number (JSCallback Unit) Unit
  , chown :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , chmod :: Fn3 FilePath Number (JSCallback Unit) Unit
  , stat :: Fn2 FilePath (JSCallback StatsObj) Unit
  , link :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , symlink :: Fn4 FilePath FilePath String (JSCallback Unit) Unit
  , readlink :: Fn2 FilePath (JSCallback FilePath) Unit
  , realpath :: forall cache. Fn3 FilePath { | cache } (JSCallback FilePath) Unit
  , unlink :: Fn2 FilePath (JSCallback Unit) Unit
  , rmdir :: Fn2 FilePath (JSCallback Unit) Unit
  , mkdir :: Fn3 FilePath Number (JSCallback Unit) Unit
  , readdir :: Fn2 FilePath (JSCallback [FilePath]) Unit
  , utimes :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , readFile :: forall a opts. Fn3 FilePath { | opts } (JSCallback a) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , appendFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , exists :: forall a. Fn2 FilePath (Boolean -> a) Unit
  }

foreign import mkEff
  "function mkEff(action) {\
  \  return action;\
  \}" :: forall eff a. (Unit -> a) -> Eff eff a

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either Error a -> Eff eff Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rename oldFile newFile cb = mkEff $ \_ -> runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Callback eff Unit
                     -> Eff (fs :: FS | eff) Unit

truncate file len cb = mkEff $ \_ -> runFn3
  fs.truncate file len (handleCallback cb)

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chown file uid gid cb = mkEff $ \_ -> runFn4
  fs.chown file uid gid (handleCallback cb)

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chmod file mode cb = mkEff $ \_ -> runFn3
  fs.chmod file mode (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = mkEff $ \_ -> runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Callback eff Unit
                 -> Eff (fs :: FS | eff) Unit

link src dst cb = mkEff $ \_ -> runFn3
  fs.link src dst (handleCallback cb)

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Callback eff Unit
                    -> Eff (fs :: FS | eff) Unit

symlink src dest ty cb = mkEff $ \_ -> runFn4
  fs.symlink src dest (show ty) (handleCallback cb)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

readlink path cb = mkEff $ \_ -> runFn2
  fs.readlink path (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

realpath path cb = mkEff $ \_ -> runFn3
  fs.realpath path {} (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Callback eff FilePath
                            -> Eff (fs :: FS | eff) Unit

realpath' path cache cb = mkEff $ \_ -> runFn3
  fs.realpath path cache (handleCallback cb)

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

unlink file cb = mkEff $ \_ -> runFn2
  fs.unlink file (handleCallback cb)

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rmdir file cb = mkEff $ \_ -> runFn2
  fs.rmdir file (handleCallback cb)

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

mkdir = flip mkdir' 777

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Number
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

mkdir' file mode cb = mkEff $ \_ -> runFn3
  fs.mkdir file mode (handleCallback cb)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Callback eff [FilePath]
                    -> Eff (fs :: FS | eff) Unit

readdir file cb = mkEff $ \_ -> runFn2
  fs.readdir file (handleCallback cb)

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

utimes file atime mtime cb = mkEff $ \_ -> runFn4
  fs.utimes file
            ((toEpochMilliseconds atime) / 1000)
            ((toEpochMilliseconds mtime) / 1000)
            (handleCallback cb)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = mkEff $ \_ -> runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = mkEff $ \_ -> runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Callback eff Unit
                       -> Eff (fs :: FS | eff) Unit

appendFile file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff {} (handleCallback cb)

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Callback eff Unit
                           -> Eff (fs :: FS | eff) Unit

appendTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> (Boolean -> Eff eff Unit)
                   -> Eff (fs :: FS | eff) Unit
exists file cb = mkEff $ \_ -> runFn2
  fs.exists file $ \b -> runPure (unsafeInterleaveEff (cb b))

module Node.FS.Async
  ( Callback (..)
  , rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Either
import Data.Function
import Data.Maybe
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())

foreign import data Nullable :: * -> *

type JSCallback a = Fn2 (Nullable Error) a Unit

foreign import handleCallbackImpl
  "function handleCallbackImpl(left, right, f) {\
  \  return function(err, value) {\
  \    if (err) f(left(err))();\
  \    else f(right(value))();\
  \  };\
  \}" :: forall eff a. Fn3 (Error -> Either Error a)
                           (a -> Either Error a)
                           (Callback eff a)
                           (JSCallback a)

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a
handleCallback cb = runFn3 handleCallbackImpl Left Right cb

foreign import fs "var fs = require('fs');" ::
  { rename :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , truncate :: Fn3 FilePath Number (JSCallback Unit) Unit
  , chown :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , chmod :: Fn3 FilePath Number (JSCallback Unit) Unit
  , stat :: Fn2 FilePath (JSCallback StatsObj) Unit
  , link :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , symlink :: Fn4 FilePath FilePath String (JSCallback Unit) Unit
  , readlink :: Fn2 FilePath (JSCallback FilePath) Unit
  , realpath :: forall cache. Fn3 FilePath { | cache } (JSCallback FilePath) Unit
  , unlink :: Fn2 FilePath (JSCallback Unit) Unit
  , rmdir :: Fn2 FilePath (JSCallback Unit) Unit
  , mkdir :: Fn3 FilePath Number (JSCallback Unit) Unit
  , readdir :: Fn2 FilePath (JSCallback [FilePath]) Unit
  , utimes :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , readFile :: forall a opts. Fn3 FilePath { | opts } (JSCallback a) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , appendFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , exists :: forall a. Fn2 FilePath (Boolean -> a) Unit
  }

foreign import mkEff
  "function mkEff(action) {\
  \  return action;\
  \}" :: forall eff a. (Unit -> a) -> Eff eff a

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either Error a -> Eff eff Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rename oldFile newFile cb = mkEff $ \_ -> runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Callback eff Unit
                     -> Eff (fs :: FS | eff) Unit

truncate file len cb = mkEff $ \_ -> runFn3
  fs.truncate file len (handleCallback cb)

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chown file uid gid cb = mkEff $ \_ -> runFn4
  fs.chown file uid gid (handleCallback cb)

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chmod file mode cb = mkEff $ \_ -> runFn3
  fs.chmod file mode (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = mkEff $ \_ -> runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Callback eff Unit
                 -> Eff (fs :: FS | eff) Unit

link src dst cb = mkEff $ \_ -> runFn3
  fs.link src dst (handleCallback cb)

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Callback eff Unit
                    -> Eff (fs :: FS | eff) Unit

symlink src dest ty cb = mkEff $ \_ -> runFn4
  fs.symlink src dest (show ty) (handleCallback cb)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

readlink path cb = mkEff $ \_ -> runFn2
  fs.readlink path (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

realpath path cb = mkEff $ \_ -> runFn3
  fs.realpath path {} (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Callback eff FilePath
                            -> Eff (fs :: FS | eff) Unit

realpath' path cache cb = mkEff $ \_ -> runFn3
  fs.realpath path cache (handleCallback cb)

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

unlink file cb = mkEff $ \_ -> runFn2
  fs.unlink file (handleCallback cb)

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rmdir file cb = mkEff $ \_ -> runFn2
  fs.rmdir file (handleCallback cb)

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

mkdir = flip mkdir' 777

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Number
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

mkdir' file mode cb = mkEff $ \_ -> runFn3
  fs.mkdir file mode (handleCallback cb)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Callback eff [FilePath]
                    -> Eff (fs :: FS | eff) Unit

readdir file cb = mkEff $ \_ -> runFn2
  fs.readdir file (handleCallback cb)

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

utimes file atime mtime cb = mkEff $ \_ -> runFn4
  fs.utimes file
            ((toEpochMilliseconds atime) / 1000)
            ((toEpochMilliseconds mtime) / 1000)
            (handleCallback cb)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = mkEff $ \_ -> runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = mkEff $ \_ -> runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Callback eff Unit
                       -> Eff (fs :: FS | eff) Unit

appendFile file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff {} (handleCallback cb)

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Callback eff Unit
                           -> Eff (fs :: FS | eff) Unit

appendTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> (Boolean -> Eff eff Unit)
                   -> Eff (fs :: FS | eff) Unit
exists file cb = mkEff $ \_ -> runFn2
  fs.exists file $ \b -> runPure (unsafeInterleaveEff (cb b))


Adding "mil" and "mils" to Parser

Adding "mil" and "mils" to Parser

As discussed in this issue: https://github.com/sharkdp/insect/pull/195

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , prefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, (./))
import Quantities as Q

import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (foldr, traverse_)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.Map (lookup)
import Data.String (fromCodePointArray, codePointFromChar, singleton)

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..),
                        Identifier)
import Insect.Environment (Environment, StoredFunction(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "%", "^", "!",
                      "**", "=", ","]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    fromCharArray = fromCodePointArray <<< map codePointFromChar

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton (codePointFromChar sign) <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure identity

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henrys","henries","henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU", "au", "astronomicalunits", "astronomicalunit"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "amps", "amp", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  , Q.pixel ==> ["pixels", "pixel", "px"]
  , Q.frame ==> ["frames", "frame"]
  , Q.frame ./ Q.second ==> ["fps"]
  , Q.dot ==> ["dots", "dot"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.percent ==> ["pct", "percent"]
  , Q.partsPerMillion ==> ["ppm"]
  , Q.partsPerBillion ==> ["ppb"]
  , Q.partsPerTrillion ==> ["ppt"]
  , Q.partsPerQuadrillion ==> ["ppq"]
  , Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.thou ==> ["thou", "mils", "mil"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.lbf ==> ["pound_force", "lbf"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  , Q.pixel ./ Q.inch ==> ["ppi"]
  , Q.dot ./ Q.inch ==> ["dpi"]
  , Q.piece ==> ["pieces", "piece"]
  , Q.person ==> ["persons", "person", "people"]
  , Q.dollar ==> ["dollars", "dollar", "USD", "$"]
  , Q.euro ==> ["euros", "euro", "EUR", "€"]
  , Q.knot ==> ["knots", "knot", "kn", "kt"]
  , Q.nauticalMile ==> ["M", "NM", "nmi"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← prefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  if name == "sum" || name == "product"
    then
      pure name
    else
      case lookup name env.functions of
        Just (StoredFunction _ fn) → pure name
        Nothing → fail ("Unknown function '" <> name <> "'")

-- | Parse a full mathematical expression.
expression ∷ Environment → P Expression
expression env =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> function env <*> parens (sepBy1 p commaOp))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      -- The power operator needs special treatment
      -- 1) it is right-associative => use foldr1 instead of foldl1
      -- 2) the unary minus on the *left* side of the power operator has
      --    a lower precedence, i.e. -2^3 = -(2^3). However, unary minus
      --    on the *right* side has a higher precedence: 2^-3 = 2^(-3).
      sepByPow ∷ P Expression
      sepByPow = fix \e → foldr1 (BinOp Pow) <$> list e
        where
          list e = do
            a ← suffixPow
            as ← many do
              powOp
              func ← (subOp *> pure Negate) <|> (addOp *> pure identity) <|> pure identity
              expr ← e
              pure (func expr)
            pure (a :| as)

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      prefixed ∷ P Expression
      prefixed = fix \e →
            (subOp *> (Negate <$> e))
        <|> (addOp *> e)
        <|> sepByMulImplicit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> prefixed `sepBy1` modOp

      sepByPer ∷ P Expression
      sepByPer = foldl1 (BinOp Div) <$> sepByMod `sepBy1` perOp

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByPer `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> sepByMul `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    perOp = reserved "per"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ Environment → P Expression
fullExpression env = do
  whiteSpace
  expr ← expression env
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name: name, args: args, expr: expr }

  -- Fail if the name can be parsed as a physical unit
  failIfUnit name

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → do
      traverse_ failIfUnit xs
      pure (FunctionAssignment name xs expr)

  where
    failIfUnit n =
      when (isRight $ runParser n (derivedUnit <* eof)) $
        fail ("'" <> n <> "' is reserved for a physical unit")

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (Expression <$> fullExpression env)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ Environment → String → Either ParseError Statement
parseInsect env inp = runParser inp (statement env)

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , prefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, (./))
import Quantities as Q

import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (foldr, traverse_)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.Map (lookup)
import Data.String (fromCodePointArray, codePointFromChar, singleton)

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..),
                        Identifier)
import Insect.Environment (Environment, StoredFunction(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "%", "^", "!",
                      "**", "=", ","]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    fromCharArray = fromCodePointArray <<< map codePointFromChar

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton (codePointFromChar sign) <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure identity

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henrys","henries","henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU", "au", "astronomicalunits", "astronomicalunit"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "amps", "amp", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  , Q.pixel ==> ["pixels", "pixel", "px"]
  , Q.frame ==> ["frames", "frame"]
  , Q.frame ./ Q.second ==> ["fps"]
  , Q.dot ==> ["dots", "dot"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.percent ==> ["pct", "percent"]
  , Q.partsPerMillion ==> ["ppm"]
  , Q.partsPerBillion ==> ["ppb"]
  , Q.partsPerTrillion ==> ["ppt"]
  , Q.partsPerQuadrillion ==> ["ppq"]
  , Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.thou ==> ["thou"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.lbf ==> ["pound_force", "lbf"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  , Q.pixel ./ Q.inch ==> ["ppi"]
  , Q.dot ./ Q.inch ==> ["dpi"]
  , Q.piece ==> ["pieces", "piece"]
  , Q.person ==> ["persons", "person", "people"]
  , Q.dollar ==> ["dollars", "dollar", "USD", "$"]
  , Q.euro ==> ["euros", "euro", "EUR", "€"]
  , Q.knot ==> ["knots", "knot", "kn", "kt"]
  , Q.nauticalMile ==> ["M", "NM", "nmi"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← prefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  if name == "sum" || name == "product"
    then
      pure name
    else
      case lookup name env.functions of
        Just (StoredFunction _ fn) → pure name
        Nothing → fail ("Unknown function '" <> name <> "'")

-- | Parse a full mathematical expression.
expression ∷ Environment → P Expression
expression env =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> function env <*> parens (sepBy1 p commaOp))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      -- The power operator needs special treatment
      -- 1) it is right-associative => use foldr1 instead of foldl1
      -- 2) the unary minus on the *left* side of the power operator has
      --    a lower precedence, i.e. -2^3 = -(2^3). However, unary minus
      --    on the *right* side has a higher precedence: 2^-3 = 2^(-3).
      sepByPow ∷ P Expression
      sepByPow = fix \e → foldr1 (BinOp Pow) <$> list e
        where
          list e = do
            a ← suffixPow
            as ← many do
              powOp
              func ← (subOp *> pure Negate) <|> (addOp *> pure identity) <|> pure identity
              expr ← e
              pure (func expr)
            pure (a :| as)

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      prefixed ∷ P Expression
      prefixed = fix \e →
            (subOp *> (Negate <$> e))
        <|> (addOp *> e)
        <|> sepByMulImplicit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> prefixed `sepBy1` modOp

      sepByPer ∷ P Expression
      sepByPer = foldl1 (BinOp Div) <$> sepByMod `sepBy1` perOp

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByPer `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> sepByMul `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    perOp = reserved "per"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ Environment → P Expression
fullExpression env = do
  whiteSpace
  expr ← expression env
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name: name, args: args, expr: expr }

  -- Fail if the name can be parsed as a physical unit
  failIfUnit name

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → do
      traverse_ failIfUnit xs
      pure (FunctionAssignment name xs expr)

  where
    failIfUnit n =
      when (isRight $ runParser n (derivedUnit <* eof)) $
        fail ("'" <> n <> "' is reserved for a physical unit")

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (Expression <$> fullExpression env)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ Environment → String → Either ParseError Statement
parseInsect env inp = runParser inp (statement env)


Cosmetics

Cosmetics

module Routing.Bob where

import Data.Array as Data.Array
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
import Data.Array (length)
import Data.Foldable (foldr)
import Data.Generic (class Generic, DataConstructor, fromSpine, GenericSignature(..), GenericSpine(..), toSignature, toSpine)
import Data.List (fromFoldable, List(..), reverse, (:))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.String (split)
import Partial.Unsafe (unsafePartial)
import Prelude (Unit, pure, bind, show, unit, map, const, ($), (<<<), (<$>), (<>), (==))
import Text.Boomerang.Combinators (maph, nil, cons)
import Text.Boomerang.HStack (HNil, HCons)
import Text.Boomerang.Prim (Boomerang)
import Text.Boomerang.String (StringBoomerang, parse, serialize, int, lit, many1NoneOf, string)
import Type.Proxy (Proxy(..))

join :: forall a b c. StringBoomerang b c -> StringBoomerang a b -> StringBoomerang a c
join b1 b2 = b1 <<< lit "/" <<< b2

infixl 6 join as </>

boolean :: forall r. StringBoomerang r (HCons Boolean r)
boolean =
  boolean' <<< (string "on" <> string "off")
 where
  boolean' :: forall s. StringBoomerang (HCons String s) (HCons Boolean s)
  boolean' =
    maph prs ser
   where
    prs "on" = true
    prs _    = false

    ser true  = Just "on"
    ser false = Just "off"

foreign import encodeURIComponent :: String -> String
foreign import decodeURIComponent :: String -> String
foreign import camelsToHyphens :: String -> String

str :: forall r. StringBoomerang r (HCons String r)
str =
  maph (decodeURIComponent) (Just <<< encodeURIComponent) <<< many1NoneOf "/?#"

arrayFromList :: forall t a tok. Boomerang tok (HCons (List a) t) (HCons (Array a) t)
arrayFromList =
  maph arrayFromFoldable (Just <<< fromFoldable)
 where
  -- very ineficient - will be replaced with next purescript-array release
  arrayFromFoldable = foldr Data.Array.cons []

intersperce :: forall tok a t. (List (Boomerang tok (HCons (List a) t) (HCons a (HCons (List a) t)))) ->
                               (forall r. Boomerang tok r r) ->
                               Boomerang tok t (HCons (List a) t)
intersperce Nil _ = nil
intersperce (Cons b t) sep =
  cons <<< b <<< foldr step nil t
 where
  step e l = sep <<< cons <<< e <<< l

signatureToSpineBoomerang :: forall r. GenericSignature -> Maybe (StringBoomerang r (HCons GenericSpine r))
signatureToSpineBoomerang s@(SigProd n cs) = do
  { head : h, tail: t} <- Data.Array.uncons cs
  if length t == 0
    then
      fromConstructor h false
    else do
      hs <- fromConstructor h true
      Data.Array.foldM (\r c -> (_ <> r) <$> (fromConstructor c true)) hs t
 where
  fromConstructor :: DataConstructor -> Boolean -> Maybe (StringBoomerang r (HCons GenericSpine r))
  fromConstructor constructor prependWithConstructorName = do
    let values = map (_ $ unit) constructor.sigValues
    valuesSpines <- reverse <$> Data.Array.foldM (\r e -> (\b -> (lazy <<< b) : r) <$> signatureToSpineBoomerang e) Nil values
    let bmg = maph (SProd constructor.sigConstructor) ser <<< arrayFromList <<< intersperce valuesSpines (lit "/")
    if prependWithConstructorName
      then do
        let cn = serializeConstructorName constructor.sigConstructor
        if length values == 0
          then pure (lit cn <<< bmg)
          else pure (lit cn </> bmg)
      else pure bmg
   where
    lazy :: forall z y. StringBoomerang (HCons y z) (HCons (Unit -> y) z)
    lazy = maph const (Just <<< (_ $ unit))

    ser (SProd c values) =
      if c == constructor.sigConstructor
        then Just values
        else Nothing
    ser _                = Nothing
signatureToSpineBoomerang SigBoolean =
  Just (maph SBoolean ser <<< boolean)
 where
  ser (SBoolean b) = Just b
  ser _            = Nothing
signatureToSpineBoomerang SigInt =
  Just (maph SInt ser <<< int)
 where
  ser (SInt b) = Just b
  ser _        = Nothing
signatureToSpineBoomerang SigString =
  Just (maph SString ser <<< str)
 where
  ser (SString s) = Just s
  ser _        = Nothing
signatureToSpineBoomerang _ = Nothing

bob :: forall a r. (Generic a) => Proxy a -> Maybe (StringBoomerang r (HCons a r))
bob p = do
  sb <- (signatureToSpineBoomerang (toSignature p))
  pure (maph prs (\v -> Just (Just v)) <<< maph fromSpine (toSpine <$> _) <<< sb)
 where
  prs (Just s) = s
  prs Nothing = unsafeThrow ("Incorrect spine generated for signature: " <> show (toSignature p))

serializeConstructorName :: String -> String
serializeConstructorName n =
  camelsToHyphens (fromMaybe n (Data.Array.last <<< split "." $ n))

genericToUrl :: forall a. (Generic a) => a -> Maybe String
genericToUrl a = do
  route <- bob (Proxy :: Proxy a)
  serialize route a

genericFromUrl :: forall a. (Generic a) => String -> Maybe a
genericFromUrl s = do
  route <- bob (Proxy :: Proxy a)
  parse route s

data Router a = Router (StringBoomerang HNil (HCons a HNil))

router :: forall a. (Generic a) => Proxy a -> Maybe (Router a)
router p = do
  b <- bob p
  pure $ Router b

toUrl :: forall a. Router a -> a -> String
toUrl (Router bmg) a =
  unsafePartial (case serialize bmg a of Just url -> url)

fromUrl :: forall a. Router a -> String -> Maybe a
fromUrl (Router bmg) s =
  parse bmg s

module Routing.Bob where

import Data.Array as Data.Array
import Data.List as List
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
import Data.Array (length)
import Data.Foldable (foldr)
import Data.Generic (class Generic, DataConstructor, fromSpine, GenericSignature(..), GenericSpine(..), toSignature, toSpine)
import Data.List (reverse, List(..), (:))
import Data.List (fromFoldable, List)
import Data.Maybe (fromMaybe, Maybe(..))
import Data.String (split, toLower)
import Partial.Unsafe (unsafePartial)
import Prelude (bind, const, id, map, pure, show, unit, Unit, (<<<), (<>), (==), (<$>), ($), (>))
import Text.Boomerang.Combinators (cons, list, maph, nil)
import Text.Boomerang.HStack (HNil(HNil), HCons)
import Text.Boomerang.Prim (Boomerang)
import Text.Boomerang.String (int, lit, many1NoneOf, noneOf, parse, StringBoomerang, serialize, string)
import Type.Proxy (Proxy(..))

join :: forall a b c. StringBoomerang b c -> StringBoomerang a b -> StringBoomerang a c
join b1 b2 = b1 <<< lit "/" <<< b2

infixl 6 join as </>

boolean :: forall r. StringBoomerang r (HCons Boolean r)
boolean =
  boolean' <<< (string "on" <> string "off")
 where
  boolean' :: forall s. StringBoomerang (HCons String s) (HCons Boolean s)
  boolean' =
    maph prs ser
   where
    prs "on" = true
    prs _    = false

    ser true  = Just "on"
    ser false = Just "off"

foreign import encodeURIComponent :: String -> String
foreign import decodeURIComponent :: String -> String
foreign import camelsToHyphens :: String -> String

str :: forall r. StringBoomerang r (HCons String r)
str =
  maph (decodeURIComponent) (Just <<< encodeURIComponent) <<< many1NoneOf "/?#"

arrayFromList :: forall t a tok. Boomerang tok (HCons (List a) t) (HCons (Array a) t)
arrayFromList =
  maph arrayFromFoldable (Just <<< fromFoldable)
 where
  -- very ineficient - will be replaced with next purescript-array release
  arrayFromFoldable = foldr Data.Array.cons []

intersperce :: forall tok a t. (List (Boomerang tok (HCons (List a) t) (HCons a (HCons (List a) t)))) ->
                               (forall r. Boomerang tok r r) ->
                               Boomerang tok t (HCons (List a) t)
intersperce Nil _ = nil
intersperce (Cons b t) sep =
  cons <<< b <<< foldr step nil t
 where
  step e l = sep <<< cons <<< e <<< l

signatureToSpineBoomerang :: forall r. GenericSignature -> Maybe (StringBoomerang r (HCons GenericSpine r))
signatureToSpineBoomerang s@(SigProd n cs) = do
  { head : h, tail: t} <- Data.Array.uncons cs
  if length t == 0
    then
      fromConstructor h false
    else do
      hs <- fromConstructor h true
      Data.Array.foldM (\r c -> (_ <> r) <$> (fromConstructor c true)) hs t
 where
  fromConstructor :: DataConstructor -> Boolean -> Maybe (StringBoomerang r (HCons GenericSpine r))
  fromConstructor constructor prependWithConstructorName = do
    let values = map (_ $ unit) constructor.sigValues
    valuesSpines <- reverse <$> Data.Array.foldM (\r e -> (\b -> (lazy <<< b) : r) <$> signatureToSpineBoomerang e) Nil values
    let bmg = maph (SProd constructor.sigConstructor) ser <<< arrayFromList <<< intersperce valuesSpines (lit "/")
    if prependWithConstructorName
      then do
        let cn = serializeConstructorName constructor.sigConstructor
        if length values == 0
          then pure (lit cn <<< bmg)
          else pure (lit cn </> bmg)
      else pure bmg
   where
    lazy :: forall z y. StringBoomerang (HCons y z) (HCons (Unit -> y) z)
    lazy = maph const (Just <<< (_ $ unit))

    ser (SProd c values) =
      if c == constructor.sigConstructor
        then Just values
        else Nothing
    ser _                = Nothing
signatureToSpineBoomerang SigBoolean =
  Just (maph SBoolean ser <<< boolean)
 where
  ser (SBoolean b) = Just b
  ser _            = Nothing
signatureToSpineBoomerang SigInt =
  Just (maph SInt ser <<< int)
 where
  ser (SInt b) = Just b
  ser _        = Nothing
signatureToSpineBoomerang SigString =
  Just (maph SString ser <<< str)
 where
  ser (SString s) = Just s
  ser _        = Nothing
signatureToSpineBoomerang _ = Nothing

bob :: forall a r. (Generic a) => Proxy a -> Maybe (StringBoomerang r (HCons a r))
bob p = do
  sb <- (signatureToSpineBoomerang (toSignature p))
  pure (maph prs (\v -> Just (Just v)) <<< maph fromSpine (toSpine <$> _) <<< sb)
 where
  prs (Just s) = s
  prs Nothing = unsafeThrow ("Incorrect spine generated for signature: " <> show (toSignature p))

serializeConstructorName :: String -> String
serializeConstructorName n =
  camelsToHyphens (fromMaybe n (Data.Array.last <<< split "." $ n))

genericToUrl :: forall a. (Generic a) => a -> Maybe String
genericToUrl a = do
  route <- bob (Proxy :: Proxy a)
  serialize route a

genericFromUrl :: forall a. (Generic a) => String -> Maybe a
genericFromUrl s = do
  route <- bob (Proxy :: Proxy a)
  parse route s

data Router a = Router (StringBoomerang HNil (HCons a HNil))

router :: forall a. (Generic a) => Proxy a -> Maybe (Router a)
router p = do
  b <- bob p
  pure $ Router b

toUrl :: forall a. Router a -> a -> String
toUrl (Router bmg) a =
  unsafePartial (case serialize bmg a of Just url -> url)

fromUrl :: forall a. Router a -> String -> Maybe a
fromUrl (Router bmg) s =
  parse bmg s


[CSL-2047] Increase limit of block txs (#2095)

module Explorer.Api.Http where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Core (Json)
import Data.Either (Either(..), either)
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple)
import Explorer.Api.Helper (decodeResult)
import Explorer.Api.Types (Endpoint, EndpointError(..))
import Explorer.Types.State (AddressesFilter(..), CBlockEntries, CGenesisAddressInfos, CTxBriefs, CTxEntries, PageNumber(..), PageSize(..))
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AJAX, AffjaxRequest, affjax, defaultRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.StatusCode (StatusCode(..))
import Pos.Core.Lenses.Types (_EpochIndex, _UnsafeLocalSlotIndex, getEpochIndex, getSlotIndex)
import Pos.Core.Types (EpochIndex(..), LocalSlotIndex)
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary, CAddressesFilter(..), CBlockSummary, CGenesisSummary, CHash(..), CTxId, CTxSummary)
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId)

endpointPrefix :: String
endpointPrefix = "/api/"

-- result helper

decodeResponse :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResponse = decodeResult <<< _.response

request :: forall a r eff. Generic a => Requestable r => AffjaxRequest r ->
    Endpoint -> Aff (ajax :: AJAX | eff) a
request req endpoint = do
    result <- affjax $ req { url = endpointPrefix <> endpoint }
    when (isHttpError result.status) $
        throwError <<< error <<< show $ HTTPStatusError result
    either throwError pure $ decodeResponse result
    where
      isHttpError (StatusCode c) = c >= 400

get :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
get e = request defaultRequest e

post :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
post = request $ defaultRequest { method = Left POST }

-- api

-- blocks

fetchBlocksTotalPages :: forall eff. Aff (ajax::AJAX | eff) Int
fetchBlocksTotalPages = get "blocks/pages/total"

fetchPageBlocks :: forall eff. PageNumber -> PageSize -> Aff (ajax::AJAX | eff) (Tuple Int CBlockEntries)
fetchPageBlocks (PageNumber pNumber) (PageSize pSize) =
    get $ "blocks/pages/?page=" <> show pNumber <> "&pageSize=" <> show pSize

fetchBlockSummary :: forall eff. CHash -> Aff (ajax::AJAX | eff) CBlockSummary
fetchBlockSummary (CHash hash) = get $ "blocks/summary/" <> hash

fetchBlockTxs :: forall eff. CHash -> Aff (ajax::AJAX | eff) CTxBriefs
fetchBlockTxs (CHash hash) =
    get $ "blocks/txs/"
              <> hash
              <> "?limit=5000"
              -- ^ hardcoded limit as discussed in `CSL-2047`

-- txs
fetchLatestTxs :: forall eff. Aff (ajax::AJAX | eff) CTxEntries
fetchLatestTxs = get $ "txs/last"

fetchTxSummary :: forall eff. CTxId -> Aff (ajax::AJAX | eff) CTxSummary
fetchTxSummary id = get $ "txs/summary/" <> id ^. (_CTxId <<< _CHash)

-- addresses
fetchAddressSummary :: forall eff. CAddress -> Aff (ajax::AJAX | eff) CAddressSummary
fetchAddressSummary (CAddress address) = get $ "addresses/summary/" <> (encodeURIComponent address)

-- search by epoch / page
epochPageSearch :: forall eff. EpochIndex -> PageNumber -> Aff (ajax::AJAX | eff) (Tuple Int CBlockEntries)
epochPageSearch (EpochIndex epochIndex) (PageNumber pNumber) = get $ "epochs/"
    <> show (epochIndex ^. getEpochIndex) <> "?page=" <> show pNumber

-- search by epoch and slot
epochSlotSearch :: forall eff. EpochIndex -> LocalSlotIndex -> Aff (ajax::AJAX | eff) CBlockEntries
epochSlotSearch epoch slot = get $ "epochs/" <> show epochIndex <> slotQuery
    where
        slotQuery = "/" <> show (slot ^. (_UnsafeLocalSlotIndex <<< getSlotIndex))
        epochIndex = epoch ^. (_EpochIndex <<< getEpochIndex)

-- genesis block
fetchGenesisSummary :: forall eff. Aff (ajax::AJAX | eff) CGenesisSummary
fetchGenesisSummary = get "genesis/summary/"

fetchGenesisAddressInfo :: forall eff. PageNumber -> PageSize -> AddressesFilter -> Aff (ajax::AJAX | eff) CGenesisAddressInfos
fetchGenesisAddressInfo (PageNumber pNumber) (PageSize pSize) (AddressesFilter cAddrFilter) =
    get $ "genesis/address/?page="
              <> show pNumber
              <> "&pageSize="
              <> show pSize
              <> "&filter="
              <> filterGenesisAddressesValue cAddrFilter

fetchGenesisAddressInfoTotalPages :: forall eff. PageSize -> AddressesFilter -> Aff (ajax::AJAX | eff) Int
fetchGenesisAddressInfoTotalPages (PageSize pSize) (AddressesFilter cAddrFilter) =
    get $ "genesis/address/pages/total?pageSize="
              <> show pSize
              <> "&filter="
              <> filterGenesisAddressesValue cAddrFilter

filterGenesisAddressesValue :: CAddressesFilter -> String
filterGenesisAddressesValue AllAddresses = "all"
filterGenesisAddressesValue RedeemedAddresses = "redeemed"
filterGenesisAddressesValue NonRedeemedAddresses = "notredeemed"

module Explorer.Api.Http where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Core (Json)
import Data.Either (Either(..), either)
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple)
import Explorer.Api.Helper (decodeResult)
import Explorer.Api.Types (Endpoint, EndpointError(..))
import Explorer.Types.State (AddressesFilter(..), CBlockEntries, CGenesisAddressInfos, CTxBriefs, CTxEntries, PageNumber(..), PageSize(..))
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AJAX, AffjaxRequest, affjax, defaultRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.StatusCode (StatusCode(..))
import Pos.Core.Lenses.Types (_EpochIndex, _UnsafeLocalSlotIndex, getEpochIndex, getSlotIndex)
import Pos.Core.Types (EpochIndex(..), LocalSlotIndex)
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary, CAddressesFilter(..), CBlockSummary, CGenesisSummary, CHash(..), CTxId, CTxSummary)
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId)

endpointPrefix :: String
endpointPrefix = "/api/"

-- result helper

decodeResponse :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResponse = decodeResult <<< _.response

request :: forall a r eff. Generic a => Requestable r => AffjaxRequest r ->
    Endpoint -> Aff (ajax :: AJAX | eff) a
request req endpoint = do
    result <- affjax $ req { url = endpointPrefix <> endpoint }
    when (isHttpError result.status) $
        throwError <<< error <<< show $ HTTPStatusError result
    either throwError pure $ decodeResponse result
    where
      isHttpError (StatusCode c) = c >= 400

get :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
get e = request defaultRequest e

post :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
post = request $ defaultRequest { method = Left POST }

-- api

-- blocks

fetchBlocksTotalPages :: forall eff. Aff (ajax::AJAX | eff) Int
fetchBlocksTotalPages = get "blocks/pages/total"

fetchPageBlocks :: forall eff. PageNumber -> PageSize -> Aff (ajax::AJAX | eff) (Tuple Int CBlockEntries)
fetchPageBlocks (PageNumber pNumber) (PageSize pSize) =
    get $ "blocks/pages/?page=" <> show pNumber <> "&pageSize=" <> show pSize

fetchBlockSummary :: forall eff. CHash -> Aff (ajax::AJAX | eff) CBlockSummary
fetchBlockSummary (CHash hash) = get $ "blocks/summary/" <> hash

fetchBlockTxs :: forall eff. CHash -> Aff (ajax::AJAX | eff) CTxBriefs
fetchBlockTxs (CHash hash) = get $ "blocks/txs/" <> hash

-- txs
fetchLatestTxs :: forall eff. Aff (ajax::AJAX | eff) CTxEntries
fetchLatestTxs = get $ "txs/last"

fetchTxSummary :: forall eff. CTxId -> Aff (ajax::AJAX | eff) CTxSummary
fetchTxSummary id = get $ "txs/summary/" <> id ^. (_CTxId <<< _CHash)

-- addresses
fetchAddressSummary :: forall eff. CAddress -> Aff (ajax::AJAX | eff) CAddressSummary
fetchAddressSummary (CAddress address) = get $ "addresses/summary/" <> (encodeURIComponent address)

-- search by epoch / page
epochPageSearch :: forall eff. EpochIndex -> PageNumber -> Aff (ajax::AJAX | eff) (Tuple Int CBlockEntries)
epochPageSearch (EpochIndex epochIndex) (PageNumber pNumber) = get $ "epochs/"
    <> show (epochIndex ^. getEpochIndex) <> "?page=" <> show pNumber

-- search by epoch and slot
epochSlotSearch :: forall eff. EpochIndex -> LocalSlotIndex -> Aff (ajax::AJAX | eff) CBlockEntries
epochSlotSearch epoch slot = get $ "epochs/" <> show epochIndex <> slotQuery
    where
        slotQuery = "/" <> show (slot ^. (_UnsafeLocalSlotIndex <<< getSlotIndex))
        epochIndex = epoch ^. (_EpochIndex <<< getEpochIndex)

-- genesis block
fetchGenesisSummary :: forall eff. Aff (ajax::AJAX | eff) CGenesisSummary
fetchGenesisSummary = get "genesis/summary/"

fetchGenesisAddressInfo :: forall eff. PageNumber -> PageSize -> AddressesFilter -> Aff (ajax::AJAX | eff) CGenesisAddressInfos
fetchGenesisAddressInfo (PageNumber pNumber) (PageSize pSize) (AddressesFilter cAddrFilter) =
    get $ "genesis/address/?page="
              <> show pNumber
              <> "&pageSize="
              <> show pSize
              <> "&filter="
              <> filterGenesisAddressesValue cAddrFilter

fetchGenesisAddressInfoTotalPages :: forall eff. PageSize -> AddressesFilter -> Aff (ajax::AJAX | eff) Int
fetchGenesisAddressInfoTotalPages (PageSize pSize) (AddressesFilter cAddrFilter) =
    get $ "genesis/address/pages/total?pageSize="
              <> show pSize
              <> "&filter="
              <> filterGenesisAddressesValue cAddrFilter

filterGenesisAddressesValue :: CAddressesFilter -> String
filterGenesisAddressesValue AllAddresses = "all"
filterGenesisAddressesValue RedeemedAddresses = "redeemed"
filterGenesisAddressesValue NonRedeemedAddresses = "notredeemed"


Add deprecation warning to unsafeCompare

module Data.Ord.Unsafe (unsafeCompare) where

import Prim.TypeError (class Warn, Text)
import Data.Ordering (Ordering(..))

unsafeCompare
    :: forall a.
       Warn (Text "'unsafeCompare' is deprecated.")
    => a -> a -> Ordering
unsafeCompare = unsafeCompareImpl LT EQ GT

foreign import unsafeCompareImpl
  :: forall a
   . Ordering
  -> Ordering
  -> Ordering
  -> a
  -> a
  -> Ordering

module Data.Ord.Unsafe (unsafeCompare) where

import Data.Ordering (Ordering(..))

unsafeCompare :: forall a. a -> a -> Ordering
unsafeCompare = unsafeCompareImpl LT EQ GT

foreign import unsafeCompareImpl
  :: forall a
   . Ordering
  -> Ordering
  -> Ordering
  -> a
  -> a
  -> Ordering


Use lookup from Data.Foldable

Use lookup from Data.Foldable

module Language.PureScript.CodeGen.Externs (moduleToPs) where

import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Data.Array (filter, map, mapMaybe, null)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foldable (elem, find, for_, traverse_, lookup)
import Data.Monoid
import Data.String (joinWith)
import Data.Tuple
import Data.Tuple3

import qualified Data.Map as M

import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.Errors (theImpossibleHappened)
import Language.PureScript.Names
import Language.PureScript.Pretty.Kinds
import Language.PureScript.Pretty.Types
import Language.PureScript.TypeClassDictionaries

-- |
-- Generate foreign imports for all declarations in a module
--
moduleToPs :: Module -> Environment -> String
moduleToPs (Module _ _ Nothing) _ = theImpossibleHappened "Module exports were not elaborated in moduleToPs"
moduleToPs (Module moduleName ds (Just exts)) (Environment env) = joinWith "\n" <<< execWriter $ do
  tell [ "module " ++ runModuleName moduleName ++ " where"]
  traverse_ declToPs ds
  traverse_ exportToPs exts
  where

    declToPs :: Declaration -> Writer [String] Unit
    declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
    declToPs (FixityDeclaration (Fixity assoc prec) ident) =
      tell [ joinWith " " [ show assoc, show prec, ident ] ]
    declToPs (PositionedDeclaration _ d) = declToPs d
    declToPs _ = return unit

    exportToPs :: DeclarationRef -> Writer [String] Unit
    exportToPs (PositionedDeclarationRef _ r) = exportToPs r
    exportToPs (TypeRef pn dctors) =
      case Qualified (Just moduleName) pn `M.lookup` env.types of
        Nothing -> theImpossibleHappened $ show pn ++ " has no kind in exportToPs"
        Just (Tuple kind ExternData) ->
          tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
        Just (Tuple _ (DataType args tys)) -> do
          let dctors' = fromMaybe (map fst tys) dctors
              printDctor dctor = case dctor `lookup` tys of
                                   Nothing -> Nothing
                                   Just tyArgs -> Just $ show dctor ++ " " ++ joinWith " " (map prettyPrintTypeAtom tyArgs)
          tell ["data " ++ show pn ++ " " ++ joinWith " " args ++ (if null dctors' then "" else " = " ++ joinWith " | " (mapMaybe printDctor dctors'))]
        Just (Tuple _ TypeSynonym) ->
          case Qualified (Just moduleName) pn `M.lookup` env.typeSynonyms of
            Nothing -> theImpossibleHappened $ show pn ++ " has no type synonym info in exportToPs"
            Just (Tuple args synTy) ->
              tell ["type " ++ show pn ++ " " ++ joinWith " " args ++ " = " ++ prettyPrintType synTy]
        _ -> theImpossibleHappened "Invalid input in exportToPs"

    exportToPs (ValueRef ident) =
      case (Tuple moduleName ident) `M.lookup` env.names of
        Nothing -> theImpossibleHappened $ show ident ++ " has no type in exportToPs"
        Just (Tuple ty nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
          tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
        _ -> return unit
    exportToPs (TypeClassRef className) =
      case Qualified (Just moduleName) className `M.lookup` env.typeClasses of
        Nothing -> theImpossibleHappened $ show className ++ " has no type class definition in exportToPs"
        Just (Tuple3 args members implies) -> do
          let impliesString = if null implies then "" else "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
          let exportedMembers = filter (isValueExported <<< fst) members
          tell ["class " ++ impliesString ++ show className ++ " " ++ joinWith " " args ++ (if null exportedMembers then "" else " where")]
          for_ exportedMembers $ \(Tuple member ty) ->
            tell [ "  " ++ show member ++ " :: " ++ prettyPrintType ty ]

    exportToPs (TypeInstanceRef ident) = do
      case find (((==) (Qualified (Just moduleName) ident)) <<< (\(TypeClassDictionaryInScope tcd) -> tcd.name)) $ M.values env.typeClassDictionaries of
        Nothing -> theImpossibleHappened "Type class instance has no dictionary in exportToPs"
        Just (TypeClassDictionaryInScope tcd) -> do
          let constraintsText = case fromMaybe [] tcd.dependencies of
                                  [] -> ""
                                  cs -> "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) cs) ++ ") => "
          tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show tcd.className ++ " " ++ joinWith " " (map prettyPrintTypeAtom tcd.instanceTypes)]

    isValueExported :: Ident -> Boolean
    isValueExported ident = ValueRef ident `elem` exts

module Language.PureScript.CodeGen.Externs (moduleToPs) where

import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Data.Array (filter, map, mapMaybe, null)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foldable (elem, find, for_, traverse_)
import Data.Monoid
import Data.String (joinWith)
import Data.Tuple
import Data.Tuple3

import qualified Data.Map as M

import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.Errors (theImpossibleHappened)
import Language.PureScript.Names
import Language.PureScript.Pretty.Kinds
import Language.PureScript.Pretty.Types
import Language.PureScript.TypeClassDictionaries

-- |
-- Generate foreign imports for all declarations in a module
--
moduleToPs :: Module -> Environment -> String
moduleToPs (Module _ _ Nothing) _ = theImpossibleHappened "Module exports were not elaborated in moduleToPs"
moduleToPs (Module moduleName ds (Just exts)) (Environment env) = joinWith "\n" <<< execWriter $ do
  tell [ "module " ++ runModuleName moduleName ++ " where"]
  traverse_ declToPs ds
  traverse_ exportToPs exts
  where

    declToPs :: Declaration -> Writer [String] Unit
    declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
    declToPs (FixityDeclaration (Fixity assoc prec) ident) =
      tell [ joinWith " " [ show assoc, show prec, ident ] ]
    declToPs (PositionedDeclaration _ d) = declToPs d
    declToPs _ = return unit

    exportToPs :: DeclarationRef -> Writer [String] Unit
    exportToPs (PositionedDeclarationRef _ r) = exportToPs r
    exportToPs (TypeRef pn dctors) =
      case Qualified (Just moduleName) pn `M.lookup` env.types of
        Nothing -> theImpossibleHappened $ show pn ++ " has no kind in exportToPs"
        Just (Tuple kind ExternData) ->
          tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
        Just (Tuple _ (DataType args tys)) -> do
          let dctors' = fromMaybe (map fst tys) dctors
              printDctor dctor = case dctor `lookup` tys of
                                   Nothing -> Nothing
                                   Just tyArgs -> Just $ show dctor ++ " " ++ joinWith " " (map prettyPrintTypeAtom tyArgs)
          tell ["data " ++ show pn ++ " " ++ joinWith " " args ++ (if null dctors' then "" else " = " ++ joinWith " | " (mapMaybe printDctor dctors'))]
        Just (Tuple _ TypeSynonym) ->
          case Qualified (Just moduleName) pn `M.lookup` env.typeSynonyms of
            Nothing -> theImpossibleHappened $ show pn ++ " has no type synonym info in exportToPs"
            Just (Tuple args synTy) ->
              tell ["type " ++ show pn ++ " " ++ joinWith " " args ++ " = " ++ prettyPrintType synTy]
        _ -> theImpossibleHappened "Invalid input in exportToPs"

    exportToPs (ValueRef ident) =
      case (Tuple moduleName ident) `M.lookup` env.names of
        Nothing -> theImpossibleHappened $ show ident ++ " has no type in exportToPs"
        Just (Tuple ty nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
          tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
        _ -> return unit
    exportToPs (TypeClassRef className) =
      case Qualified (Just moduleName) className `M.lookup` env.typeClasses of
        Nothing -> theImpossibleHappened $ show className ++ " has no type class definition in exportToPs"
        Just (Tuple3 args members implies) -> do
          let impliesString = if null implies then "" else "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
          let exportedMembers = filter (isValueExported <<< fst) members
          tell ["class " ++ impliesString ++ show className ++ " " ++ joinWith " " args ++ (if null exportedMembers then "" else " where")]
          for_ exportedMembers $ \(Tuple member ty) ->
            tell [ "  " ++ show member ++ " :: " ++ prettyPrintType ty ]

    exportToPs (TypeInstanceRef ident) = do
      case find (((==) (Qualified (Just moduleName) ident)) <<< (\(TypeClassDictionaryInScope tcd) -> tcd.name)) $ M.values env.typeClassDictionaries of
        Nothing -> theImpossibleHappened "Type class instance has no dictionary in exportToPs"
        Just (TypeClassDictionaryInScope tcd) -> do
          let constraintsText = case fromMaybe [] tcd.dependencies of
                                  [] -> ""
                                  cs -> "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) cs) ++ ") => "
          tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show tcd.className ++ " " ++ joinWith " " (map prettyPrintTypeAtom tcd.instanceTypes)]

    isValueExported :: Ident -> Boolean
    isValueExported ident = ValueRef ident `elem` exts

    -- TODO: put this somewhere else
    lookup :: forall a b. (Eq a) => a -> [Tuple a b] -> Maybe b
    lookup key ((Tuple x y) : xys) = if key == x then Just y else lookup key xys
    lookup _ [] = Nothing


Update src/Effect/Console.purs

Update src/Effect/Console.purs

Co-Authored-By: Gary Burgess <9bcc5ea709c714d920d22027d854793da53a5299@gmail.com>

module Effect.Console where

import Effect (Effect)

import Data.Show (class Show, show)
import Data.Unit (Unit)

-- | Write a message to the console.
foreign import log
  :: String
  -> Effect Unit

-- | Write a value to the console, using its `Show` instance to produce a
-- | `String`.
logShow :: forall a. Show a => a -> Effect Unit
logShow a = log (show a)

-- | Write an warning to the console.
foreign import warn
  :: String
  -> Effect Unit

-- | Write an warning value to the console, using its `Show` instance to produce
-- | a `String`.
warnShow :: forall a. Show a => a -> Effect Unit
warnShow a = warn (show a)

-- | Write an error to the console.
foreign import error
  :: String
  -> Effect Unit

-- | Write an error value to the console, using its `Show` instance to produce a
-- | `String`.
errorShow :: forall a. Show a => a -> Effect Unit
errorShow a = error (show a)

-- | Write an info message to the console.
foreign import info
  :: String
  -> Effect Unit

-- | Write an info value to the console, using its `Show` instance to produce a
-- | `String`.
infoShow :: forall a. Show a => a -> Effect Unit
infoShow a = info (show a)

-- | Start a named timer.
foreign import time :: String -> Effect Unit

-- | Print the time since a named timer started in milliseconds.
foreign import timeLog :: String -> Effect Unit

-- | Stop a named timer and print time since it started in milliseconds.
foreign import timeEnd :: String -> Effect Unit

module Effect.Console where

import Effect (Effect)

import Data.Show (class Show, show)
import Data.Unit (Unit)

-- | Write a message to the console.
foreign import log
  :: String
  -> Effect Unit

-- | Write a value to the console, using its `Show` instance to produce a
-- | `String`.
logShow :: forall a. Show a => a -> Effect Unit
logShow a = log (show a)

-- | Write an warning to the console.
foreign import warn
  :: String
  -> Effect Unit

-- | Write an warning value to the console, using its `Show` instance to produce
-- | a `String`.
warnShow :: forall a. Show a => a -> Effect Unit
warnShow a = warn (show a)

-- | Write an error to the console.
foreign import error
  :: String
  -> Effect Unit

-- | Write an error value to the console, using its `Show` instance to produce a
-- | `String`.
errorShow :: forall a. Show a => a -> Effect Unit
errorShow a = error (show a)

-- | Write an info message to the console.
foreign import info
  :: String
  -> Effect Unit

-- | Write an info value to the console, using its `Show` instance to produce a
-- | `String`.
infoShow :: forall a. Show a => a -> Effect Unit
infoShow a = info (show a)

-- | Start a named timer.
foreign import time :: String -> Effect Unit

-- | Print time since it started in milliseconds.
foreign import timeLog :: String -> Effect Unit

-- | Stop a named timer and print time since it started in milliseconds.
foreign import timeEnd :: String -> Effect Unit