applicative approach

applicative approach

module KanColle.DamageAnalysis where

import Prelude
import Data.Array
import Data.Array.Unsafe as AU
import Data.Maybe
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

rawSplit :: forall a. Array a -> {left :: Array a, right :: Array a}
rawSplit = fleetSplit true

normalSplit :: forall a. Array a -> {left :: Array a, right :: Array a}
normalSplit = fleetSplit false

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = rawSplit (getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = rawSplit (getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: false, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = AU.tail (getInitHpsCombined battle)
    escortMaxHps = AU.tail (getMaxHpsCombined battle)

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: false, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

module KanColle.DamageAnalysis where

import Prelude
import Data.Array
import Data.Array.Unsafe as AU
import Data.Maybe
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

rawSplit :: forall a. Array a -> {left :: Array a, right :: Array a}
rawSplit = fleetSplit true

normalSplit :: forall a. Array a -> {left :: Array a, right :: Array a}
normalSplit = fleetSplit false

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = rawSplit (getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = rawSplit (getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: false, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = AU.tail (getInitHpsCombined battle)
    escortMaxHps = AU.tail (getMaxHpsCombined battle)

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: false, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    { main: zipWith getShipResult' initFleet.main finalFleet.main
    , enemy: zipWith getShipResult' initFleet.enemy finalFleet.enemy
    }
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    { main: zipWith getShipResult' initFleet.main finalFleet.main
    , enemy: zipWith getShipResult' initFleet.enemy finalFleet.enemy
    , escort: zipWith getShipResult' initFleet.escort finalFleet.escort
    }
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    { main: zipWith getShipResult' initFleet.main finalFleet.main
    , enemy: zipWith getShipResult' initFleet.enemy finalFleet.enemy
    }
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2


Fix indentation after changes to let

Fix indentation after changes to let

module Data.Foreign
  ( Foreign(..)
  , ForeignParser(ForeignParser)
  , parseForeign
  , parseJSON
  , ReadForeign
  , read
  , prop
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Data.Traversable

foreign import data Foreign :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String Foreign

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String a

foreign import readMaybeImpl
  "function readMaybeImpl (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. Foreign -> Maybe Foreign

foreign import readPropImpl
  "function readPropImpl (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String Foreign

foreign import showForeignImpl
  "var showForeignImpl = JSON.stringify;" :: Foreign -> String

instance showForeign :: Prelude.Show Foreign where
  show = showForeignImpl

data ForeignParser a = ForeignParser (Foreign -> Either String a)

parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
parseForeign (ForeignParser p) x = p x

parseJSON :: forall a. (ReadForeign a) => String -> Either String a
parseJSON json = fromString json >>= parseForeign read

instance monadForeignParser :: Prelude.Monad ForeignParser where
  return x = ForeignParser \_ -> Right x
  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
      Left err -> Left err
      Right x' -> parseForeign (f x') x

instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
  pure x = ForeignParser \_ -> Right x
  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorForeignParser :: Prelude.Functor ForeignParser where
  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x

class ReadForeign a where
  read :: ForeignParser a

instance readString :: ReadForeign String where
  read = ForeignParser $ readPrimType "String"

instance readNumber :: ReadForeign Number where
  read = ForeignParser $ readPrimType "Number"

instance readBoolean :: ReadForeign Boolean where
  read = ForeignParser $ readPrimType "Boolean"

instance readArray :: (ReadForeign a) => ReadForeign [a] where
  read = let
    arrayItem (Tuple i x) = case parseForeign read x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (ForeignParser $ readPrimType "Array") >>= \xs ->
      ForeignParser \_ -> arrayItem `traverse` (zip (range 0 (length xs)) xs)

instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
  read = (ForeignParser $ Right <<< readMaybeImpl) >>= \x ->
    ForeignParser \_ -> case x of
      Just x' -> parseForeign read x' >>= return <<< Just
      Nothing -> return Nothing

prop :: forall a. (ReadForeign a) => String -> ForeignParser a
prop p = (ForeignParser \x -> readPropImpl p x) >>= \x ->
  ForeignParser \_ -> case parseForeign read x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err


optimise indexl indexr

optimise indexl indexr

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , foldM
  , traverse_
  , for_
  , sequence_
  , oneOf
  , oneOfMap
  , intercalate
  , surroundMap
  , surround
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , indexl
  , indexr
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)

import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> acc <> f x) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap id

-- | Similar to 'foldl', but the result is encapsulated in a monad.
-- |
-- | Note: this function is not generally stack-safe, e.g., for monads which
-- | build up thunks a la `Eff`.
foldM :: forall f m a b. Foldable f => Monad m => (a -> b -> m a) -> a -> f b -> m a
foldM f a0 = foldl (\ma b -> ma >>= flip f b) (pure a0)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ id

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Folds a structure into some `Plus`.
oneOfMap :: forall f g a b. Foldable f => Plus g => (a -> g b) -> f a -> g b
oneOfMap f = foldr (alt <<< f) empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | `foldMap` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMap "*" show []
-- | = "*"
-- |
-- | > surroundMap "*" show [1]
-- | = "*1*"
-- |
-- | > surroundMap "*" show [1, 2]
-- | = "*1*2*"
-- |
-- | > surroundMap "*" show [1, 2, 3]
-- | = "*1*2*3*"
-- | ```
surroundMap :: forall f a m. Foldable f => Semigroup m => m -> (a -> m) -> f a -> m
surroundMap d t f = unwrap (foldMap joined f) d
  where joined a = Endo \m -> d <> t a <> m

-- | `fold` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surround "*" []
-- | = "*"
-- |
-- | > surround "*" ["1"]
-- | = "*1*"
-- |
-- | > surround "*" ["1", "2"]
-- | = "*1*2*"
-- |
-- | > surround "*" ["1", "2", "3"]
-- | = "*1*2*3*"
-- | ```
surround :: forall f m. Foldable f => Semigroup m => m -> f m -> m
surround d = surroundMap d id

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all id

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any id

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to get nth element from the left in a data structure
indexl :: forall a f. Foldable f => Int -> f a -> Maybe a
indexl idx = _.elem <<< foldl go { elem: Nothing, pos: 0 }
  where
  go cursor elem =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just elem, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to get nth element from the right in a data structure
indexr :: forall a f. Foldable f => Int -> f a -> Maybe a
indexr idx = _.elem <<< foldr go { elem: Nothing, pos: 0 }
  where
  go elem cursor =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just elem, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. Foldable f => Semiring b => f a -> b
length = foldl (\c _ -> add one c) zero

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , foldM
  , traverse_
  , for_
  , sequence_
  , oneOf
  , oneOfMap
  , intercalate
  , surroundMap
  , surround
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , indexl
  , indexr
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)

import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> acc <> f x) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap id

-- | Similar to 'foldl', but the result is encapsulated in a monad.
-- |
-- | Note: this function is not generally stack-safe, e.g., for monads which
-- | build up thunks a la `Eff`.
foldM :: forall f m a b. Foldable f => Monad m => (a -> b -> m a) -> a -> f b -> m a
foldM f a0 = foldl (\ma b -> ma >>= flip f b) (pure a0)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ id

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Folds a structure into some `Plus`.
oneOfMap :: forall f g a b. Foldable f => Plus g => (a -> g b) -> f a -> g b
oneOfMap f = foldr (alt <<< f) empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | `foldMap` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMap "*" show []
-- | = "*"
-- |
-- | > surroundMap "*" show [1]
-- | = "*1*"
-- |
-- | > surroundMap "*" show [1, 2]
-- | = "*1*2*"
-- |
-- | > surroundMap "*" show [1, 2, 3]
-- | = "*1*2*3*"
-- | ```
surroundMap :: forall f a m. Foldable f => Semigroup m => m -> (a -> m) -> f a -> m
surroundMap d t f = unwrap (foldMap joined f) d
  where joined a = Endo \m -> d <> t a <> m

-- | `fold` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surround "*" []
-- | = "*"
-- |
-- | > surround "*" ["1"]
-- | = "*1*"
-- |
-- | > surround "*" ["1", "2"]
-- | = "*1*2*"
-- |
-- | > surround "*" ["1", "2", "3"]
-- | = "*1*2*3*"
-- | ```
surround :: forall f m. Foldable f => Semigroup m => m -> f m -> m
surround d = surroundMap d id

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all id

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any id

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to get nth element from the left in a data structure
indexl :: forall a f. Foldable f => Int -> f a -> Maybe a
indexl idx = _.elem <<< foldl go { elem: Nothing, pos: 0 }
  where
  go cursor@{ pos } elem' | pos == idx =
    cursor{pos = cursor.pos + 1, elem = Just elem'}
  go cursor _ =
    cursor{pos = cursor.pos + 1}

-- | Try to get nth element from the right in a data structure
indexr :: forall a f. Foldable f => Int -> f a -> Maybe a
indexr idx = _.elem <<< foldr go { elem: Nothing, pos: 0 }
  where
  go elem' cursor@{ pos } | pos == idx =
    cursor{pos = cursor.pos + 1, elem = Just elem'}
  go _ cursor =
    cursor{pos = cursor.pos + 1}

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. Foldable f => Semiring b => f a -> b
length = foldl (\c _ -> add one c) zero


Throw error if 'version' misconfigured

Throw error if 'version' misconfigured

-- |
-- | Docopt utility surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , parse
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Control.Applicative (liftA1)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Foldable (any, intercalate)
import Data.Either (Either(..), either)
import Control.Monad.Eff (Eff())
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.StrMap (StrMap())
import Data.Array as A
import Data.StrMap (member)
import Data.Bifunctor (lmap, bimap)
import Data.String.Yarn (lines, unlines)
import Data.String (trim) as String
import Language.Docopt.Errors (developerErrorMessage)

import Language.Docopt (Docopt, parseDocopt, evalDocopt)
import Language.Docopt.Value (Value())
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: ∀ e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |

type ParseOptionsObj r = {
  smartOptions :: Boolean     -- ^ parse singleton groups as opts if possible
  | r
}

type Options r = {
  argv         :: Maybe Argv   -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env    -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean      -- ^ enable "option-first"
, dontExit     :: Boolean      -- ^ don't exit the process upon failure
, smartOptions :: Boolean      -- ^ parse singleton groups as opts if possible
, stopAt       :: Array String -- ^ stop parsing at these custom EOA markers
, requireFlags :: Boolean      -- ^ do not ignore missing flags
, laxPlacement :: Boolean      -- ^ allow positionals/commands to be appear anywhere
, version      :: Maybe String -- ^ the version string to display
, versionFlags :: Array String -- ^ list of flags that trigger 'version'
, helpFlags    :: Array String -- ^ list of flags that trigger 'help'
}

defaultOptions :: Options {}
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
, smartOptions: false
, stopAt:       []
, laxPlacement: false
, requireFlags: false
, version:      Nothing
, versionFlags: [ "--version" ]
, helpFlags:    [ "--help"    ]
}

-- |
-- | Parse the docopt specification from the given help text.
-- |
parse :: ∀ e r
       . String
      -> ParseOptionsObj r
      -> Eff (DocoptEff e) Docopt
parse helpText opts = do
  either (throwException <<< error) pure do
    parseDocopt helpText opts

data Action a
  = ShowHelp String
  | ShowVersion
  | Return a

-- |
-- | Run docopt on the given help text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: ∀ e r
     . Either Docopt String
    -> Options r
    -> Eff (DocoptEff e) (StrMap Value)
run input opts = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  program /\ action <- runEither do
    { program, specification, shortHelp, help } <- case input of
        (Left spec)   -> pure spec
        (Right help') -> parseDocopt help' opts

    bimap
      (fmtHelp program opts.helpFlags shortHelp)
      ((program /\ _) <<< case _ of
        output | canExit && output `has` opts.helpFlags    -> ShowHelp help
        output | canExit && output `has` opts.versionFlags -> ShowVersion
        output                                             -> Return output
      )
      (evalDocopt program specification env argv opts)

  case action of
    Return v      -> pure v
    ShowHelp help -> abort 0 (String.trim help)
    ShowVersion   -> do
      mVer <- maybe readPkgVersion (pure <<< pure) opts.version
      case mVer of
        Just ver -> abort 0 ver
        Nothing  -> abort 1
          $ program
              <> ": version not detected."
              <> "\n"
              <> developerErrorMessage
      abort 0 ""

  where
    has x = any (_ `member` x)
    canExit = not opts.dontExit

    -- note: purescript needs the `a` for now:
    abort :: ∀ a. _ -> _ -> _ _ a
    abort _ msg | opts.dontExit = throwException (error msg)
    abort code msg
      = let log = if code == 0 then Console.log else Console.error
        in  do
          log msg
          Process.exit code

    runEither = flip either pure (abort 1)

    readPkgVersion = readPkgVersionImpl Just Nothing

    fmtHelp program helpFlags shortHelp errmsg
      = errmsg
      <> "\n"
      <> (dedent $ unlines $ ("  " <> _) <$> lines (dedent shortHelp))
      <> if A.length helpFlags == 0
          then ""
          else "\n" <> "See "
                        <> program <> " " <> (intercalate "/" helpFlags)
                        <> " for more information"

foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)

-- |
-- | Docopt utility surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , parse
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Control.Applicative (liftA1)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Foldable (any, intercalate)
import Data.Either (Either(..), either)
import Control.Monad.Eff (Eff())
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.StrMap (StrMap())
import Data.Array as A
import Data.StrMap (member)
import Data.Bifunctor (lmap, bimap)
import Data.String.Yarn (lines, unlines)
import Data.String (trim) as String

import Language.Docopt (Docopt, parseDocopt, evalDocopt)
import Language.Docopt.Value (Value())
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: ∀ e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |

type ParseOptionsObj r = {
  smartOptions :: Boolean     -- ^ parse singleton groups as opts if possible
  | r
}

type Options r = {
  argv         :: Maybe Argv   -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env    -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean      -- ^ enable "option-first"
, dontExit     :: Boolean      -- ^ don't exit the process upon failure
, smartOptions :: Boolean      -- ^ parse singleton groups as opts if possible
, stopAt       :: Array String -- ^ stop parsing at these custom EOA markers
, requireFlags :: Boolean      -- ^ do not ignore missing flags
, laxPlacement :: Boolean      -- ^ allow positionals/commands to be appear anywhere
, version      :: Maybe String -- ^ the version string to display
, versionFlags :: Array String -- ^ list of flags that trigger 'version'
, helpFlags    :: Array String -- ^ list of flags that trigger 'help'
}

defaultOptions :: Options {}
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
, smartOptions: false
, stopAt:       []
, laxPlacement: false
, requireFlags: false
, version:      Nothing
, versionFlags: [ "--version" ]
, helpFlags:    [ "--help"    ]
}

-- |
-- | Parse the docopt specification from the given help text.
-- |
parse :: ∀ e r
       . String
      -> ParseOptionsObj r
      -> Eff (DocoptEff e) Docopt
parse helpText opts = do
  either (throwException <<< error) pure do
    parseDocopt helpText opts

data Action a
  = ShowHelp String
  | ShowVersion
  | Return a

-- |
-- | Run docopt on the given help text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: ∀ e r
     . Either Docopt String
    -> Options r
    -> Eff (DocoptEff e) (StrMap Value)
run input opts = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  action <- runEither do
    { program, specification, shortHelp, help } <- case input of
      (Left spec)   -> pure spec
      (Right help') -> parseDocopt help' opts

    bimap
      (fmtHelp program opts.helpFlags shortHelp)
      case _ of
        output | output `has` opts.helpFlags    -> ShowHelp help
        output | output `has` opts.versionFlags -> ShowVersion
        output                                  -> Return output
      (evalDocopt program specification env argv opts)

  case action of
    Return v      -> pure v
    ShowHelp help -> abort 0 (String.trim help)
    ShowVersion   -> abort 0 =<< String.trim <$> maybe readPkgVersion
                                                       pure
                                                       opts.version

  where
    has x = any (_ `member` x)

    -- note: purescript needs the `a` for now:
    abort :: ∀ a. _ -> _ -> _ _ a
    abort code msg
      = let log = if code == 0 then Console.log else Console.error
        in  do
          log msg
          Process.exit code

    runEither = flip either pure \e ->
      if not opts.dontExit
        then abort 1 e
        else throwException $ error $ e

    readPkgVersion = fromMaybe "" <$> readPkgVersionImpl Just Nothing

    fmtHelp program helpFlags shortHelp errmsg
      = errmsg
      <> "\n"
      <> (dedent $ unlines $ ("  " <> _) <$> lines (dedent shortHelp))
      <> if A.length helpFlags == 0
          then ""
          else "\n" <> "See "
                        <> program <> " " <> (intercalate "/" helpFlags)
                        <> " for more information"

foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)