Don't render deck frame name in publish mode (#1679)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Component.Render
  ( renderDeck
  , renderError
  ) where

import SlamData.Prelude
import Data.Array as A
import Data.List as L

import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Render.CSS as RCSS
import SlamData.Render.Icon as I
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.Component.CSS as CCSS
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML)
import SlamData.Workspace.Deck.Common as Common
import SlamData.Workspace.Deck.Component.CSS as CSS
import SlamData.Workspace.Deck.Component.ChildSlot (cpBackSide, cpDialog, cpActionFilter)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..))
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Hint as Hint
import Utils (endSentence)
import Utils.DOM as DOM

renderError ∷ ∀ f a. String → HH.HTML a (f Unit)
renderError err =
  HH.div
    [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
    [ HH.h1_
        [ HH.text "Couldn't load this SlamData deck." ]
    , HH.p_
        [ HH.text $ endSentence err ]
    ]

renderDeck ∷ DeckOptions → (DeckOptions → DeckComponent) → DCS.State → DeckHTML
renderDeck opts deckComponent st =
  HH.div
    [ HP.classes
        [ HH.ClassName "sd-deck-nested"
        , HH.ClassName ("sd-deck-level-" <> show (L.length opts.displayCursor + 1))
        ]
    ]
    $ [ HH.div
          (deckClasses st
          ⊕ deckProperties opts
          ⊕ Slider.containerProperties st)
          [ HH.div
              [ HP.class_ CSS.deckFrame
              , HE.onMouseDown $ HE.input Defocus
              ]
              $ frameElements opts st
          , HH.div
              [ HP.class_ CSS.deck
              ]
              [ Slider.render opts deckComponent st $ DCS.isFrontSide st.displayMode
              , renderBackside
                  $ DCS.isFlipSide st.displayMode
              , renderDialog $ DCS.hasDialog st.displayMode
              ]
          ]
      ]
      <> (guard presentFocusDeckHint $> renderFocusDeckHint)
      <> (guard presentFocusDeckFrameHint $> renderFocusDeckFrameHint)

  where
  presentFocusDeckHint ∷ Boolean
  presentFocusDeckHint =
    Common.willBePresentedWithChildFrameWhenFocused opts st
      ∧ (not st.focused)
      ∧ (not st.focusDeckHintDismissed)

  presentFocusDeckFrameHint ∷ Boolean
  presentFocusDeckFrameHint =
    Common.willBePresentedWithChildFrameWhenFocused opts st
      ∧ st.focused
      ∧ (not st.focusDeckFrameHintDismissed)

  renderFocusDeckHint ∷ DeckHTML
  renderFocusDeckHint =
    Hint.render
      Hint.DownArrow
      (HH.ClassName "sd-focus-deck-hint")
      DCQ.DismissFocusDeckHint
      "This Deck is wrapped in a Dashboard Card and unfocused. To do more with this Deck focus it by clicking or tapping on it."

  renderFocusDeckFrameHint ∷ DeckHTML
  renderFocusDeckFrameHint =
    Hint.render
      Hint.UpArrow
      (HH.ClassName "sd-focus-deck-frame-hint")
      DCQ.DismissFocusDeckFrameHint
      "This Deck is focused. To do more with the containing Deck focus it by clicking or tapping on the empty space in this Deck Frame."

  renderDialog visible =
    HH.div
      [ HP.classes $ [] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ dialogSlot ]

  renderBackside visible =
    HH.div
      [ HP.classes $ [CSS.cardSlider] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ backside ]

deckClasses ∷ ∀ r. DCS.State → Array (HP.IProp (class ∷ String | r) (Query Unit))
deckClasses st =
  pure $ HP.classes $
    [ CSS.deckContainer
    , HH.ClassName (responsiveSize st.responsiveSize)
    , if st.focused then CSS.focused else CSS.unfocused
    ]

deckProperties ∷ ∀ r. DeckOptions → Array (HP.IProp (onMouseDown ∷ DOM.MouseEvent | r) (Query Unit))
deckProperties opts =
  [ HP.ref Common.sizerRef ]
  <> (guard (L.length opts.displayCursor <= 1) $> HE.onMouseDown (HE.input Focus))

renderName ∷ String → DeckHTML
renderName name =
  HH.div
    [ HP.class_ CSS.deckName ]
    [ HH.text name ]

frameElements ∷ DeckOptions → DCS.State → Array DeckHTML
frameElements { accessType, displayCursor } st
  | accessType ≡ AT.ReadOnly = mempty
  | L.null displayCursor = rootFrameElements st
  | otherwise = childFrameElements st

rootFrameElements ∷ DCS.State → Array DeckHTML
rootFrameElements st =
  [ zoomOutButton
  , flipButton
  , deckIndicator st
  , renderName st.name
  ]

childFrameElements ∷ DCS.State → Array DeckHTML
childFrameElements st =
  [ zoomInButton
  , flipButton
  , moveGripper
  , deckIndicator st
  , renderName st.name
  ]

dialogSlot ∷ DeckHTML
dialogSlot =
  HH.slot' cpDialog unit Dialog.component unit (HE.input HandleDialog)

backside ∷ DeckHTML
backside =
  HH.div
    [ HP.classes [ CSS.card ] ]
    [ HH.div_
        [ HH.div
            [ HP.class_ CCSS.deckCard ]
            [ HH.div
                [ HP.class_ RCSS.deckBackSide ]
                [ HH.slot' cpActionFilter unit ActionFilter.component
                    "Filter deck and card actions"
                    (HE.input HandleBackFilter)
                , HH.slot' cpBackSide unit ActionList.component
                    unit
                    (HE.input HandleBackAction)
                ]
            ]
        ]
    ]

deckIndicator ∷ DCS.State → DeckHTML
deckIndicator st =
  HH.div [ HP.classes [ HH.ClassName "indicator" ] ] $
    A.mapWithIndex renderCircle st.displayCards

  where
  activeCard =
    DCS.activeCardIndex st

  classes ix card =
    map HH.ClassName
    $ (guard (st.pendingCardIndex ≡ Just ix) $> "running")
    ⊕ (A.singleton case card of
          Right _ → "available"
          Left DCS.PendingCard → "pending"
          Left (DCS.ErrorCard _) → "errored"
          Left (DCS.NextActionCard _) → "placeholder")
    ⊕ (guard (activeCard ≡ ix) $> "focused")

  renderCircle ix card =
    HH.i [ HP.classes $ classes ix card ] [ HH.text "" ]

flipButton ∷ DeckHTML
flipButton =
  HH.button
    [ HP.classes [ CSS.flipDeck ]
    , HE.onClick (HE.input_ FlipDeck)
    , ARIA.label "Flip deck"
    , HP.title "Flip deck"
    ]
    []

moveGripper ∷ DeckHTML
moveGripper =
  HH.button
    [ HP.classes [ CSS.grabDeck ]
    , HE.onMouseDown (HE.input HandleGrab)
    , ARIA.label "Grab deck"
    , HP.title "Grab deck"
    ]
    []

zoomInButton ∷ DeckHTML
zoomInButton =
  HH.button
     [ HP.classes [ CSS.zoomDeck ]
     , ARIA.label "Zoom in"
     , HP.title "Zoom in"
     , HE.onClick (HE.input_ ZoomIn)
     ]
     [ I.zoomInSm ]

zoomOutButton ∷ DeckHTML
zoomOutButton =
  HH.button
   [ HP.classes [ CSS.zoomDeck ]
   , ARIA.label "Zoom out"
   , HP.title "Zoom out"
   , HE.onClick (HE.input_ ZoomOut)
   ]
   [ I.zoomOutSm ]

responsiveSize ∷ DCS.ResponsiveSize → String
responsiveSize = case _ of
  DCS.XSmall  → "sd-size-xsmall"
  DCS.Small   → "sd-size-small"
  DCS.Medium  → "sd-size-medium"
  DCS.Large   → "sd-size-large"
  DCS.XLarge  → "sd-size-xlarge"
  DCS.XXLarge → "sd-size-xxlarge"

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Component.Render
  ( renderDeck
  , renderError
  ) where

import SlamData.Prelude
import Data.Array as A
import Data.List as L

import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Render.CSS as RCSS
import SlamData.Render.Icon as I
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.Component.CSS as CCSS
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML)
import SlamData.Workspace.Deck.Common as Common
import SlamData.Workspace.Deck.Component.CSS as CSS
import SlamData.Workspace.Deck.Component.ChildSlot (cpBackSide, cpDialog, cpActionFilter)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..))
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Hint as Hint
import Utils (endSentence)
import Utils.DOM as DOM

renderError ∷ ∀ f a. String → HH.HTML a (f Unit)
renderError err =
  HH.div
    [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
    [ HH.h1_
        [ HH.text "Couldn't load this SlamData deck." ]
    , HH.p_
        [ HH.text $ endSentence err ]
    ]

renderDeck ∷ DeckOptions → (DeckOptions → DeckComponent) → DCS.State → DeckHTML
renderDeck opts deckComponent st =
  HH.div
    [ HP.classes
        [ HH.ClassName "sd-deck-nested"
        , HH.ClassName ("sd-deck-level-" <> show (L.length opts.displayCursor + 1))
        ]
    ]
    $ [ HH.div
          (deckClasses st
          ⊕ deckProperties opts
          ⊕ Slider.containerProperties st)
          [ HH.div
              [ HP.class_ CSS.deckFrame
              , HE.onMouseDown $ HE.input Defocus
              ]
              $ frameElements opts st ⊕ [ renderName st.name ]
          , HH.div
              [ HP.class_ CSS.deck
              ]
              [ Slider.render opts deckComponent st $ DCS.isFrontSide st.displayMode
              , renderBackside
                  $ DCS.isFlipSide st.displayMode
              , renderDialog $ DCS.hasDialog st.displayMode
              ]
          ]
      ]
      <> (guard presentFocusDeckHint $> renderFocusDeckHint)
      <> (guard presentFocusDeckFrameHint $> renderFocusDeckFrameHint)

  where
  presentFocusDeckHint ∷ Boolean
  presentFocusDeckHint =
    Common.willBePresentedWithChildFrameWhenFocused opts st
      ∧ (not st.focused)
      ∧ (not st.focusDeckHintDismissed)

  presentFocusDeckFrameHint ∷ Boolean
  presentFocusDeckFrameHint =
    Common.willBePresentedWithChildFrameWhenFocused opts st
      ∧ st.focused
      ∧ (not st.focusDeckFrameHintDismissed)

  renderFocusDeckHint ∷ DeckHTML
  renderFocusDeckHint =
    Hint.render
      Hint.DownArrow
      (HH.ClassName "sd-focus-deck-hint")
      DCQ.DismissFocusDeckHint
      "This Deck is wrapped in a Dashboard Card and unfocused. To do more with this Deck focus it by clicking or tapping on it."

  renderFocusDeckFrameHint ∷ DeckHTML
  renderFocusDeckFrameHint =
    Hint.render
      Hint.UpArrow
      (HH.ClassName "sd-focus-deck-frame-hint")
      DCQ.DismissFocusDeckFrameHint
      "This Deck is focused. To do more with the containing Deck focus it by clicking or tapping on the empty space in this Deck Frame."

  renderDialog visible =
    HH.div
      [ HP.classes $ [] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ dialogSlot ]

  renderBackside visible =
    HH.div
      [ HP.classes $ [CSS.cardSlider] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ backside ]

deckClasses ∷ ∀ r. DCS.State → Array (HP.IProp (class ∷ String | r) (Query Unit))
deckClasses st =
  pure $ HP.classes $
    [ CSS.deckContainer
    , HH.ClassName (responsiveSize st.responsiveSize)
    , if st.focused then CSS.focused else CSS.unfocused
    ]

deckProperties ∷ ∀ r. DeckOptions → Array (HP.IProp (onMouseDown ∷ DOM.MouseEvent | r) (Query Unit))
deckProperties opts =
  [ HP.ref Common.sizerRef ]
  <> (guard (L.length opts.displayCursor <= 1) $> HE.onMouseDown (HE.input Focus))

renderName ∷ String → DeckHTML
renderName name =
  HH.div
    [ HP.class_ CSS.deckName ]
    [ HH.text name ]

frameElements ∷ DeckOptions → DCS.State → Array DeckHTML
frameElements { accessType, displayCursor } st
  | accessType ≡ AT.ReadOnly = mempty
  | L.null displayCursor = rootFrameElements st
  | otherwise = childFrameElements st

rootFrameElements ∷ DCS.State → Array DeckHTML
rootFrameElements st =
  [ zoomOutButton
  , flipButton
  , deckIndicator st
  ]

childFrameElements ∷ DCS.State → Array DeckHTML
childFrameElements st =
  [ zoomInButton
  , flipButton
  , moveGripper
  , deckIndicator st
  ]

dialogSlot ∷ DeckHTML
dialogSlot =
  HH.slot' cpDialog unit Dialog.component unit (HE.input HandleDialog)

backside ∷ DeckHTML
backside =
  HH.div
    [ HP.classes [ CSS.card ] ]
    [ HH.div_
        [ HH.div
            [ HP.class_ CCSS.deckCard ]
            [ HH.div
                [ HP.class_ RCSS.deckBackSide ]
                [ HH.slot' cpActionFilter unit ActionFilter.component
                    "Filter deck and card actions"
                    (HE.input HandleBackFilter)
                , HH.slot' cpBackSide unit ActionList.component
                    unit
                    (HE.input HandleBackAction)
                ]
            ]
        ]
    ]

deckIndicator ∷ DCS.State → DeckHTML
deckIndicator st =
  HH.div [ HP.classes [ HH.ClassName "indicator" ] ] $
    A.mapWithIndex renderCircle st.displayCards

  where
  activeCard =
    DCS.activeCardIndex st

  classes ix card =
    map HH.ClassName
    $ (guard (st.pendingCardIndex ≡ Just ix) $> "running")
    ⊕ (A.singleton case card of
          Right _ → "available"
          Left DCS.PendingCard → "pending"
          Left (DCS.ErrorCard _) → "errored"
          Left (DCS.NextActionCard _) → "placeholder")
    ⊕ (guard (activeCard ≡ ix) $> "focused")

  renderCircle ix card =
    HH.i [ HP.classes $ classes ix card ] [ HH.text "" ]

flipButton ∷ DeckHTML
flipButton =
  HH.button
    [ HP.classes [ CSS.flipDeck ]
    , HE.onClick (HE.input_ FlipDeck)
    , ARIA.label "Flip deck"
    , HP.title "Flip deck"
    ]
    []

moveGripper ∷ DeckHTML
moveGripper =
  HH.button
    [ HP.classes [ CSS.grabDeck ]
    , HE.onMouseDown (HE.input HandleGrab)
    , ARIA.label "Grab deck"
    , HP.title "Grab deck"
    ]
    []

zoomInButton ∷ DeckHTML
zoomInButton =
  HH.button
     [ HP.classes [ CSS.zoomDeck ]
     , ARIA.label "Zoom in"
     , HP.title "Zoom in"
     , HE.onClick (HE.input_ ZoomIn)
     ]
     [ I.zoomInSm ]

zoomOutButton ∷ DeckHTML
zoomOutButton =
  HH.button
   [ HP.classes [ CSS.zoomDeck ]
   , ARIA.label "Zoom out"
   , HP.title "Zoom out"
   , HE.onClick (HE.input_ ZoomOut)
   ]
   [ I.zoomOutSm ]

responsiveSize ∷ DCS.ResponsiveSize → String
responsiveSize = case _ of
  DCS.XSmall  → "sd-size-xsmall"
  DCS.Small   → "sd-size-small"
  DCS.Medium  → "sd-size-medium"
  DCS.Large   → "sd-size-large"
  DCS.XLarge  → "sd-size-xlarge"
  DCS.XXLarge → "sd-size-xxlarge"


fix tests

fix tests

module DamageVectorTests where

import Prelude
import Test.Unit
import Data.Foreign

import Data.String as Str
import Data.Array
import Data.Monoid
import Data.Unfoldable hiding (replicate)
import Data.Maybe
import Data.Function
import KanColle.Util
import KanColle.DamageAnalysis
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Stages.Internal
import KanColle.DamageAnalysis.FFI
import Test.Unit.Assert as Assert
import Data.Foldable
import Partial.Unsafe

import KanColle.KCAPI.Battle
import KanColle.KCAPI.Battle.AbyssalCombined as AC
import KanColle.DamageAnalysis.Stages.CTF as CTF
import KanColle.DamageAnalysis.Stages.STF as STF
import KanColle.DamageAnalysis.Stages.BothCombinedCTF as BCTF
import KanColle.DamageAnalysis.Stages.BothCombinedSTF as BSTF
import KanColle.DamageAnalysis.Stages.AbyssalCombined as AC

import BattleData

dc6 :: Array (Maybe DameCon)
dc6 = replicate 6 Nothing

dc12 :: Array (Maybe DameCon)
dc12 = replicate 12 Nothing

dvToStr :: DamageVector -> String
dvToStr dv = Str.joinWith "," $ map (damageToInt >>> show) (getDV dv)

ndvToStr :: LR DamageVector -> String
ndvToStr ndv = dvToStr ndv.left <> " -- " <> dvToStr ndv.right

acDVtoStr :: LR (LR DamageVector) -> String
acDVtoStr dvdv = dvToStr dvdv.left.left <> " -- " <> dvToStr dvdv.right.left <> " && " <> dvToStr dvdv.right.right

bothDVtoStr :: LR (LR DamageVector) -> String
bothDVtoStr dvdv =
    dvToStr dvdv.left.left <> " && " <> dvToStr dvdv.left.right <> " -- "
 <> dvToStr dvdv.right.left <> " && " <> dvToStr dvdv.right.right

testDameCon :: forall e. TestSuite e
testDameCon = do
   test "Damage: without damecon" do
      Assert.equal (1-20) (applyDamage (mkDamage 20) (mkShip 1 21 Nothing)).hp
   test "Damage: with repair team" do
      let ship = (applyDamage (mkDamage 20) (mkShip 1 21 $ Just RepairTeam))
      Assert.equal 4 ship.hp
      Assert.equal Nothing ship.dameCon
   test "Damage: with repair goddess" do
      Assert.equal 21 (applyDamage (mkDamage 20) (mkShip 1 21 $ Just RepairGoddess)).hp
   test "Damage: chained damage" do
      -- 21/21 -> -20 -> 1/21 -> -30 -> -29/21 (sinking) -> damecon consumed 21/21 -> -20 -> 1/21
      Assert.equal 1 (applyDamage (foldMap mkDamage [20,30,20]) (mkShip 21 21 $ Just RepairGoddess)).hp

testDamageVector :: forall e. TestSuite e
testDamageVector = do
    test "DamageVector: first aerial battle stage" do
      Assert.assert "sample battle1" $
          "0,0,0,4,0,0 -- 0,0,21,0,164,0" == ndvToStr (koukuDV battle1)
      Assert.assert "sample battle2" $
          ndvToStr memptyLR == ndvToStr (koukuDV battle2)
      Assert.assert "sample aerialBattle1" $
          ndvToStr memptyLR == ndvToStr (koukuDV aerialBattle1)
      Assert.assert "sample withSupportExpedition1" $
          "15,0,0,7,8,0 -- 55,0,0,0,0,0"
              == ndvToStr (koukuDV withSupportExpedition1)
    test "DamageVector: support fleet attack stage" do
      let dvF b = supportAirAttackDV b <> supportHouraiDV b
      Assert.assert "sample battle1" $
          dvToStr mempty == dvToStr (dvF battle1)
      Assert.assert "sample withSupportExpedition1" $
          "0,29,0,0,101,0"
              == dvToStr (dvF withSupportExpedition1)
      Assert.assert "sample withSupportExpedition2" $
          "0,70,20,132,40,0"
              == dvToStr (dvF withSupportExpedition2)
    test "DamageVector: abyssal combined: LBAS" do
      let dv :: LR (LR DamageVector)
          dv = landBasedAirStrikeDVsAC abyssalCombinedFleet1
      Assert.assert "sample1 (LBAS)" $
          "0,0,0,0,0,0 -- 0,0,0,0,0,0 && 0,0,0,122,0,176"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: kouku" do
      let dv :: LR (LR DamageVector)
          dv = koukuDVAC abyssalCombinedFleet1
      Assert.assert "sample1 (kouku)" $
          "0,0,0,0,0,0 -- 63,0,10,0,0,0 && 0,0,0,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: opening raigeki DV" do
      let raw :: Raigeki
          raw = unsafePartial (fromJust (getOpeningAttack abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcRaigekiDamageAC raw
      Assert.assert "sample1 (openning raigeki)" $
          "0,0,0,0,0,0 -- 0,0,0,0,0,73 && 0,0,0,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: regular raigeki DV" do
      let raw :: Raigeki
          raw = unsafePartial (fromJust (AC.getRaigeki abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcRaigekiDamageAC raw
      Assert.assert "sample1" $
          "0,0,4,0,0,0 -- 0,0,0,0,0,0 && 0,0,4,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: hougeki1" do
      let raw :: Hougeki
          raw = unsafePartial (fromJust (AC.getHougeki1 abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcHougekiDamageAC raw
      Assert.assert "sample1" $
          "9,0,0,0,0,0 -- 0,0,0,0,0,0 && 232,5,5,0,101,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: hougeki2" do
      let raw :: Hougeki
          raw = unsafePartial (fromJust (AC.getHougeki2 abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcHougekiDamageAC raw
      Assert.assert "sample1" $
          "0,0,0,0,0,0 -- 37,71,62,178,0,0 && 0,0,0,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: hougeki3" do
      let raw :: Hougeki
          raw = unsafePartial (fromJust (AC.getHougeki3 abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcHougekiDamageAC raw
      Assert.assert "sample1" $
          "0,0,0,0,0,0 -- 25,148,161,0,93,0 && 0,0,58,0,0,0"
              == acDVtoStr dv
    test "DamageVector: bothCombinedCTF: hougeki1" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.hougeki1DV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,25,0,0,0,0 && 0,0,0,0,0,0 -- 0,154,0,79,0,133 && 0,0,0,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: hougeki2" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.hougeki2DV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,6,7,0 -- 0,0,0,0,0,0 && 261,116,7,55,234,71" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: raigeki" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.raigekiDV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,0,0,0 -- 34,0,0,0,0,0 && 0,0,237,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: hougeki3" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.hougeki3DV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,0,13,0 -- 167,0,0,98,0,0 && 0,0,0,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: opening" do
      let dv :: LR (LR DamageVector)
          dv = openingDVAC bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,0,0,0 -- 0,0,91,0,0,0 && 0,0,0,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: kouku" do
      let dv :: LR (LR DamageVector)
          dv = koukuDVBC bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,4,0,0,0,0 -- 0,0,0,0,65,0 && 0,0,0,0,0,0" == bothDVtoStr dv

testDamageAnalyzer :: forall e. TestSuite e
testDamageAnalyzer =
    test "DamageAnalyzer" do
      Assert.assert "battle sample 1" $
        (merge >>> trimInfo) (analyzeBattle dc6 battle1) ==
          map Just [75,75,75,75-4,77,79-9
                   ,84-127,60-95,60-21-98,53-213-145,35-164,35-159-157]
      Assert.assert "battle sample 2" $
        (merge >>> trimInfo) (analyzeBattle dc6 battle2) ==
          map toMaybeInt [15,15-3,18,18,9999,9999
                         ,90-81-41,55-116,28,28-236,70-121,70-131]
      Assert.assert "night battle sample 1" $
        (merge >>> trimInfo) (analyzeNightBattle dc6 nightBattle1) ==
          map toMaybeInt [15,12,18,18,9999,9999,0,0,28-94,0,0,0]
      Assert.assert "night battle sample 2" $
        (merge >>> trimInfo) (analyzeNightBattle dc6 nightBattle2) ==
          map toMaybeInt [75,75,6,69,23,43,0,41-181,21-124,0,0,9999]
      Assert.assert "aerial battle sample 1" $
        (merge >>> trimInfo) (analyzeBattle dc6 aerialBattle1) ==
          map toMaybeInt [37,31,31,32,32,44-6,96,70,60,20,20,20]
      Assert.assert "ld aerial battle sample 1" $
        (merge >>> trimInfo) (analyzeBattle dc6 ldAerialBattle1) ==
          map toMaybeInt [31,56,56,42,33,29,500,9999,9999,9999,9999,9999]
      Assert.assert "night battle repair team sample 1" $
        (merge >>> trimInfo) (analyzeNightBattle repairTeam nightBattleWithDameCon1) ==
          map toMaybeInt [90,25, 13{- sinking: 22-22 = 0 -},35-27-6,26,12, 133,0,146-45-64,0,0,34]
      Assert.assert "battle with repair team sample 1" $
        (merge >>> trimInfo) (analyzeBattle repairTeam normBattleWithDameCon1) ==
          map toMaybeInt [36-28,72-5-35,50-28-11-4,8,{- sinking 5-103 -}7-3,59-34,
                          480-47-37,130,130-22-7-10-128,130-10-16-44,600-33-47,130-10]
      Assert.assert "battle with land-based airstrike" $
        (merge >>> trimInfo) (analyzeBattle dc6 normBattleWithLandBasedAir1) ==
          map toMaybeInt [63-5,52,68,29-2-19,31-20,11,
                          640-166-10-17-99-34-24-10-15-13-22,
                          70-16-148,98-10-12-210,98-12-19-9-9,35-59,35-93]
      Assert.assert "battle with land-based airstrike (combined)" $
        (mergeCombined >>> trimInfo) (analyzeSTFBattle dc12 combinedFleetWithLandBasedAir1) ==
          map toMaybeInt [81,82,58,50,57,56,
                          45,53,55,31,43,31,
                          57-42-247,35-98,35-52,20-45,20-66,20-125]
      Assert.assert "battle with land-based airstrike (2)" $
        (merge >>> trimInfo) (analyzeBattle dc6 normBattleWithLandBasedAir2) ==
          map toMaybeInt [57,30,27-5,12,37,45,
                          600,500,500, 9999,9999,9999]
      Assert.assert "battle with opening taisen" $
        (merge >>> trimInfo) (analyzeBattle dc6 normBattleWithOpeningTaisen1) ==
          map toMaybeInt [39,77,44-4,47, 9999,9999,
                          44-2-42,27-56,27-36,19-76, 9999,9999]

      Assert.assert "STF opening taisen" $
        (mergeCombined >>> trimInfo) (analyzeSTFBattle dc12 combinedFleetOpeingTaisenSTF1) ==
          map toMaybeInt [50,50,45, 9999,9999,9999,
                          44,29,33, 9999,9999,9999,
                          33-77,33-78, 9999,9999,9999,9999]
      Assert.assert "CTF opening taisen" $
        (mergeCombined >>> trimInfo) (analyzeCTFBattle dc12 combinedFleetOpeingTaisenCTF1) ==
          map toMaybeInt [54,45,45, 9999,9999,9999,
                          44,47,29,33, 9999,9999,
                          33-89,33-90, 9999,9999,9999,9999]
      Assert.assert "combined night battle 1" $
        (merge >>> trimInfo) (analyzeCombinedNightBattle dc6 combinedFleetNightBattle1) ==
          map toMaybeInt [11-1-1, 4, 23, 75, 40-26, 21,
                          314-11-73, 217-29-19, 143-15-11-26-75,61-54-24, 0,0]
      Assert.assert "combined night battle 2" $
        (merge >>> trimInfo) (analyzeCombinedNightBattle dc6 combinedFleetNightBattle2) ==
          map toMaybeInt [81,34,13,39,17,28,
                          88-158-136,0,0,0,0, 9999]
      Assert.assert "abyssal combined fleet 1" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFBattle dc6 abyssalCombinedFleet1) ==
          map toMaybeInt [96-9,38,60-4,50,16,23,
                          350-63-37-25,96-71-148,96-10-62-161,66-178,38-93,38-73,
                          57-232,76-5,76-5-4-58,38-122,35-101,35-176]
      Assert.assert "abyssal combined fleet night 1 (against main)" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFNightBattle dc6 abyssalCombinedFleetNight1) ==
          map toMaybeInt [87,38,56,50,16,23,
                          225-91-42-31-71,0,0,0,0,0,
                          0,71,9,0,0,0]
      Assert.assert "abyssal combined fleet night 2 (against escort)" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFNightBattle dc6 abyssalCombinedFleetNight2) ==
          map toMaybeInt [45,69,92,29,29,48,
                          142,27,53,21,0,0,
                          0,0,61-99-62,24-74-72,0,35-121-81]
      Assert.assert "both combined CTF 1" $
        (mergeBC >>> trimInfo) (analyzeBothCombinedCTFBattle dc12 bothCombinedCTF1) ==
          map toMaybeInt
            [67,57-25,83,52,57,45,
             50,35-4,31,52-6,53-7-13,43,
             370-34-167,88-154,88-91,80-79-98,35-65,35-133,
             57-261,76-116,76-7-237,55-55,20-234,20-71]
      Assert.assert "both combined CTF (night) 1" $
        (mergeBC >>> trimInfo) (analyzeBothCombinedNightBattle dc12 bothCombinedCTFNight1) ==
          map toMaybeInt
            [67,32,83,52,57,45,
             50,31,31-17,46,33,43,
             169-21-38-15-6-6-10-8-5-7-69,0,0,0,0,0,
             0,0,0,0,0,0]
      Assert.assert "both combined STF 1" $
        (mergeBC >>> trimInfo) (analyzeBothCombinedSTFBattle dc12 bothCombinedSTF1) ==
          map toMaybeInt
            [45,67-63-2,82,57-3-39,58-8,40,
             41-23-14,43,42,30-18,42,29,
             390,160-49-3-4-4,160,88-67-45,88-57-44,88-68,
             57-92,76-6-6-178,76-68-56,66,35-99,35-41]
      Assert.assert "battle with jet assault" $
        (merge >>> trimInfo) (analyzeBattle dc6 jetAssault1) ==
          map toMaybeInt
            [92,78,79,57,37,43,
             -54,-181 -47{- additional dmg from jet assault -},-77,-183,-84,-19]
      Assert.assert "abyssal combined fleet w/ jet assault" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFBattle dc6 jetAssaultWithAbyssalCombined1) ==
          map toMaybeInt [92,21,71,57,29,43,
                          -65,-80,-79,-25,-32,-100,
                          -25,-40 -6 {- dmg from jet -},-26,-103,-16,-75]
      Assert.assert "battle with jet assault (LBAS)" $
        (merge >>> trimInfo) (analyzeBattle dc6 jetAssaultLBAS1) ==
          map toMaybeInt
            [7,15,9999,9999,9999,9999,
             53-15{- jet dmg -},8,-50,-46,-65,-69]
  where
    repairTeam = replicate 6 (Just RepairTeam)
    toMaybeInt x = if x == 9999 then Nothing else Just x
    merge x = x.main <> x.enemy
    mergeCombined x = x.main <> x.escort <> x.enemy
    mergeAC x = x.main <> x.enemyMain <> x.enemyEscort
    mergeBC x = x.allyMain <> x.allyEscort <> x.enemyMain <> x.enemyEscort
    trimInfo :: forall a. Array (Maybe { hp :: Int | a}) -> Array (Maybe Int)
    trimInfo = (map <<< map) (\x -> x.hp)

module DamageVectorTests where

import Prelude
import Test.Unit
import Data.Foreign

import Data.String as Str
import Data.Array
import Data.Monoid
import Data.Unfoldable
import Data.Maybe
import Data.Function
import KanColle.Util
import KanColle.DamageAnalysis
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Stages.Internal
import KanColle.DamageAnalysis.FFI
import Test.Unit.Assert as Assert
import Data.Foldable
import Partial.Unsafe

import KanColle.KCAPI.Battle
import KanColle.KCAPI.Battle.AbyssalCombined as AC
import KanColle.DamageAnalysis.Stages.CTF as CTF
import KanColle.DamageAnalysis.Stages.STF as STF
import KanColle.DamageAnalysis.Stages.BothCombinedCTF as BCTF
import KanColle.DamageAnalysis.Stages.BothCombinedSTF as BSTF
import KanColle.DamageAnalysis.Stages.AbyssalCombined as AC

import BattleData

dc6 :: Array (Maybe DameCon)
dc6 = replicate 6 Nothing

dc12 :: Array (Maybe DameCon)
dc12 = replicate 12 Nothing

dvToStr :: DamageVector -> String
dvToStr dv = Str.joinWith "," $ map (damageToInt >>> show) (getDV dv)

ndvToStr :: LR DamageVector -> String
ndvToStr ndv = dvToStr ndv.left <> " -- " <> dvToStr ndv.right

acDVtoStr :: LR (LR DamageVector) -> String
acDVtoStr dvdv = dvToStr dvdv.left.left <> " -- " <> dvToStr dvdv.right.left <> " && " <> dvToStr dvdv.right.right

bothDVtoStr :: LR (LR DamageVector) -> String
bothDVtoStr dvdv =
    dvToStr dvdv.left.left <> " && " <> dvToStr dvdv.left.right <> " -- "
 <> dvToStr dvdv.right.left <> " && " <> dvToStr dvdv.right.right

testDameCon :: forall e. TestSuite e
testDameCon = do
   test "Damage: without damecon" do
      Assert.equal (1-20) (applyDamage (mkDamage 20) (mkShip 1 21 Nothing)).hp
   test "Damage: with repair team" do
      let ship = (applyDamage (mkDamage 20) (mkShip 1 21 $ Just RepairTeam))
      Assert.equal 4 ship.hp
      Assert.equal Nothing ship.dameCon
   test "Damage: with repair goddess" do
      Assert.equal 21 (applyDamage (mkDamage 20) (mkShip 1 21 $ Just RepairGoddess)).hp
   test "Damage: chained damage" do
      -- 21/21 -> -20 -> 1/21 -> -30 -> -29/21 (sinking) -> damecon consumed 21/21 -> -20 -> 1/21
      Assert.equal 1 (applyDamage (foldMap mkDamage [20,30,20]) (mkShip 21 21 $ Just RepairGoddess)).hp

testDamageVector :: forall e. TestSuite e
testDamageVector = do
    test "DamageVector: first aerial battle stage" do
      Assert.assert "sample battle1" $
          "0,0,0,4,0,0 -- 0,0,21,0,164,0" == ndvToStr (koukuDV battle1)
      Assert.assert "sample battle2" $
          ndvToStr memptyLR == ndvToStr (koukuDV battle2)
      Assert.assert "sample aerialBattle1" $
          ndvToStr memptyLR == ndvToStr (koukuDV aerialBattle1)
      Assert.assert "sample withSupportExpedition1" $
          "15,0,0,7,8,0 -- 55,0,0,0,0,0"
              == ndvToStr (koukuDV withSupportExpedition1)
    test "DamageVector: support fleet attack stage" do
      let dvF b = supportAirAttackDV b <> supportHouraiDV b
      Assert.assert "sample battle1" $
          dvToStr mempty == dvToStr (dvF battle1)
      Assert.assert "sample withSupportExpedition1" $
          "0,29,0,0,101,0"
              == dvToStr (dvF withSupportExpedition1)
      Assert.assert "sample withSupportExpedition2" $
          "0,70,20,132,40,0"
              == dvToStr (dvF withSupportExpedition2)
    test "DamageVector: abyssal combined: LBAS" do
      let dv :: LR (LR DamageVector)
          dv = landBasedAirStrikeDVsAC abyssalCombinedFleet1
      Assert.assert "sample1 (LBAS)" $
          "0,0,0,0,0,0 -- 0,0,0,0,0,0 && 0,0,0,122,0,176"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: kouku" do
      let dv :: LR (LR DamageVector)
          dv = koukuDVAC abyssalCombinedFleet1
      Assert.assert "sample1 (kouku)" $
          "0,0,0,0,0,0 -- 63,0,10,0,0,0 && 0,0,0,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: opening raigeki DV" do
      let raw :: Raigeki
          raw = unsafePartial (fromJust (getOpeningAttack abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcRaigekiDamageAC raw
      Assert.assert "sample1 (openning raigeki)" $
          "0,0,0,0,0,0 -- 0,0,0,0,0,73 && 0,0,0,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: regular raigeki DV" do
      let raw :: Raigeki
          raw = unsafePartial (fromJust (AC.getRaigeki abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcRaigekiDamageAC raw
      Assert.assert "sample1" $
          "0,0,4,0,0,0 -- 0,0,0,0,0,0 && 0,0,4,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: hougeki1" do
      let raw :: Hougeki
          raw = unsafePartial (fromJust (AC.getHougeki1 abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcHougekiDamageAC raw
      Assert.assert "sample1" $
          "9,0,0,0,0,0 -- 0,0,0,0,0,0 && 232,5,5,0,101,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: hougeki2" do
      let raw :: Hougeki
          raw = unsafePartial (fromJust (AC.getHougeki2 abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcHougekiDamageAC raw
      Assert.assert "sample1" $
          "0,0,0,0,0,0 -- 37,71,62,178,0,0 && 0,0,0,0,0,0"
              == acDVtoStr dv
    test "DamageVector: abyssal combined: hougeki3" do
      let raw :: Hougeki
          raw = unsafePartial (fromJust (AC.getHougeki3 abyssalCombinedFleet1))
          dv :: LR (LR DamageVector)
          dv = calcHougekiDamageAC raw
      Assert.assert "sample1" $
          "0,0,0,0,0,0 -- 25,148,161,0,93,0 && 0,0,58,0,0,0"
              == acDVtoStr dv
    test "DamageVector: bothCombinedCTF: hougeki1" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.hougeki1DV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,25,0,0,0,0 && 0,0,0,0,0,0 -- 0,154,0,79,0,133 && 0,0,0,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: hougeki2" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.hougeki2DV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,6,7,0 -- 0,0,0,0,0,0 && 261,116,7,55,234,71" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: raigeki" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.raigekiDV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,0,0,0 -- 34,0,0,0,0,0 && 0,0,237,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: hougeki3" do
      let dv :: LR (LR DamageVector)
          dv = BCTF.hougeki3DV bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,0,13,0 -- 167,0,0,98,0,0 && 0,0,0,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: opening" do
      let dv :: LR (LR DamageVector)
          dv = openingDVAC bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,0,0,0,0,0 -- 0,0,91,0,0,0 && 0,0,0,0,0,0" == bothDVtoStr dv
    test "DamageVector: bothCombinedCTF: kouku" do
      let dv :: LR (LR DamageVector)
          dv = koukuDVBC bothCombinedCTF1
      Assert.assert "sample1" $
          "0,0,0,0,0,0 && 0,4,0,0,0,0 -- 0,0,0,0,65,0 && 0,0,0,0,0,0" == bothDVtoStr dv

testDamageAnalyzer :: forall e. TestSuite e
testDamageAnalyzer =
    test "DamageAnalyzer" do
      Assert.assert "battle sample 1" $
        (merge >>> trimInfo) (analyzeBattle dc6 battle1) ==
          map Just [75,75,75,75-4,77,79-9
                   ,84-127,60-95,60-21-98,53-213-145,35-164,35-159-157]
      Assert.assert "battle sample 2" $
        (merge >>> trimInfo) (analyzeBattle dc6 battle2) ==
          map toMaybeInt [15,15-3,18,18,9999,9999
                         ,90-81-41,55-116,28,28-236,70-121,70-131]
      Assert.assert "night battle sample 1" $
        (merge >>> trimInfo) (analyzeNightBattle dc6 nightBattle1) ==
          map toMaybeInt [15,12,18,18,9999,9999,0,0,28-94,0,0,0]
      Assert.assert "night battle sample 2" $
        (merge >>> trimInfo) (analyzeNightBattle dc6 nightBattle2) ==
          map toMaybeInt [75,75,6,69,23,43,0,41-181,21-124,0,0,9999]
      Assert.assert "aerial battle sample 1" $
        (merge >>> trimInfo) (analyzeBattle dc6 aerialBattle1) ==
          map toMaybeInt [37,31,31,32,32,44-6,96,70,60,20,20,20]
      Assert.assert "ld aerial battle sample 1" $
        (merge >>> trimInfo) (analyzeBattle dc6 ldAerialBattle1) ==
          map toMaybeInt [31,56,56,42,33,29,500,9999,9999,9999,9999,9999]
      Assert.assert "night battle repair team sample 1" $
        (merge >>> trimInfo) (analyzeNightBattle repairTeam nightBattleWithDameCon1) ==
          map toMaybeInt [90,25, 13{- sinking: 22-22 = 0 -},35-27-6,26,12, 133,0,146-45-64,0,0,34]
      Assert.assert "battle with repair team sample 1" $
        (merge >>> trimInfo) (analyzeBattle repairTeam normBattleWithDameCon1) ==
          map toMaybeInt [36-28,72-5-35,50-28-11-4,8,{- sinking 5-103 -}7-3,59-34,
                          480-47-37,130,130-22-7-10-128,130-10-16-44,600-33-47,130-10]
      Assert.assert "battle with land-based airstrike" $
        (merge >>> trimInfo) (analyzeBattle dc6 normBattleWithLandBasedAir1) ==
          map toMaybeInt [63-5,52,68,29-2-19,31-20,11,
                          640-166-10-17-99-34-24-10-15-13-22,
                          70-16-148,98-10-12-210,98-12-19-9-9,35-59,35-93]
      Assert.assert "battle with land-based airstrike (combined)" $
        (mergeCombined >>> trimInfo) (analyzeSTFBattle dc12 combinedFleetWithLandBasedAir1) ==
          map toMaybeInt [81,82,58,50,57,56,
                          45,53,55,31,43,31,
                          57-42-247,35-98,35-52,20-45,20-66,20-125]
      Assert.assert "battle with land-based airstrike (2)" $
        (merge >>> trimInfo) (analyzeBattle dc6 normBattleWithLandBasedAir2) ==
          map toMaybeInt [57,30,27-5,12,37,45,
                          600,500,500, 9999,9999,9999]
      Assert.assert "battle with opening taisen" $
        (merge >>> trimInfo) (analyzeBattle dc6 normBattleWithOpeningTaisen1) ==
          map toMaybeInt [39,77,44-4,47, 9999,9999,
                          44-2-42,27-56,27-36,19-76, 9999,9999]

      Assert.assert "STF opening taisen" $
        (mergeCombined >>> trimInfo) (analyzeSTFBattle dc12 combinedFleetOpeingTaisenSTF1) ==
          map toMaybeInt [50,50,45, 9999,9999,9999,
                          44,29,33, 9999,9999,9999,
                          33-77,33-78, 9999,9999,9999,9999]
      Assert.assert "CTF opening taisen" $
        (mergeCombined >>> trimInfo) (analyzeCTFBattle dc12 combinedFleetOpeingTaisenCTF1) ==
          map toMaybeInt [54,45,45, 9999,9999,9999,
                          44,47,29,33, 9999,9999,
                          33-89,33-90, 9999,9999,9999,9999]
      Assert.assert "combined night battle 1" $
        (merge >>> trimInfo) (analyzeCombinedNightBattle dc6 combinedFleetNightBattle1) ==
          map toMaybeInt [11-1-1, 4, 23, 75, 40-26, 21,
                          314-11-73, 217-29-19, 143-15-11-26-75,61-54-24, 0,0]
      Assert.assert "combined night battle 2" $
        (merge >>> trimInfo) (analyzeCombinedNightBattle dc6 combinedFleetNightBattle2) ==
          map toMaybeInt [81,34,13,39,17,28,
                          88-158-136,0,0,0,0, 9999]
      Assert.assert "abyssal combined fleet 1" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFBattle dc6 abyssalCombinedFleet1) ==
          map toMaybeInt [96-9,38,60-4,50,16,23,
                          350-63-37-25,96-71-148,96-10-62-161,66-178,38-93,38-73,
                          57-232,76-5,76-5-4-58,38-122,35-101,35-176]
      Assert.assert "abyssal combined fleet night 1 (against main)" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFNightBattle dc6 abyssalCombinedFleetNight1) ==
          map toMaybeInt [87,38,56,50,16,23,
                          225-91-42-31-71,0,0,0,0,0,
                          0,71,9,0,0,0]
      Assert.assert "abyssal combined fleet night 2 (against escort)" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFNightBattle dc6 abyssalCombinedFleetNight2) ==
          map toMaybeInt [45,69,92,29,29,48,
                          142,27,53,21,0,0,
                          0,0,61-99-62,24-74-72,0,35-121-81]
      Assert.assert "both combined CTF 1" $
        (mergeBC >>> trimInfo) (analyzeBothCombinedCTFBattle dc12 bothCombinedCTF1) ==
          map toMaybeInt
            [67,57-25,83,52,57,45,
             50,35-4,31,52-6,53-7-13,43,
             370-34-167,88-154,88-91,80-79-98,35-65,35-133,
             57-261,76-116,76-7-237,55-55,20-234,20-71]
      Assert.assert "both combined CTF (night) 1" $
        (mergeBC >>> trimInfo) (analyzeBothCombinedNightBattle dc12 bothCombinedCTFNight1) ==
          map toMaybeInt
            [67,32,83,52,57,45,
             50,31,31-17,46,33,43,
             169-21-38-15-6-6-10-8-5-7-69,0,0,0,0,0,
             0,0,0,0,0,0]
      Assert.assert "both combined STF 1" $
        (mergeBC >>> trimInfo) (analyzeBothCombinedSTFBattle dc12 bothCombinedSTF1) ==
          map toMaybeInt
            [45,67-63-2,82,57-3-39,58-8,40,
             41-23-14,43,42,30-18,42,29,
             390,160-49-3-4-4,160,88-67-45,88-57-44,88-68,
             57-92,76-6-6-178,76-68-56,66,35-99,35-41]
      Assert.assert "battle with jet assault" $
        (merge >>> trimInfo) (analyzeBattle dc6 jetAssault1) ==
          map toMaybeInt
            [92,78,79,57,37,43,
             -54,-181 -47{- additional dmg from jet assault -},-77,-183,-84,-19]
      Assert.assert "abyssal combined fleet w/ jet assault" $
        (mergeAC >>> trimInfo) (analyzeAbyssalCTFBattle dc6 jetAssaultWithAbyssalCombined1) ==
          map toMaybeInt [92,21,71,57,29,43,
                          -65,-80,-79,-25,-32,-100,
                          -25,-40 -6 {- dmg from jet -},-26,-103,-16,-75]
      Assert.assert "battle with jet assault (LBAS)" $
        (merge >>> trimInfo) (analyzeBattle dc6 jetAssaultLBAS1) ==
          map toMaybeInt
            [7,15,9999,9999,9999,9999,
             53-15{- jet dmg -},8,-50,-46,-65,-69]
  where
    repairTeam = replicate 6 (Just RepairTeam)
    toMaybeInt x = if x == 9999 then Nothing else Just x
    merge x = x.main <> x.enemy
    mergeCombined x = x.main <> x.escort <> x.enemy
    mergeAC x = x.main <> x.enemyMain <> x.enemyEscort
    mergeBC x = x.allyMain <> x.allyEscort <> x.enemyMain <> x.enemyEscort
    trimInfo :: forall a. Array (Maybe { hp :: Int | a}) -> Array (Maybe Int)
    trimInfo = (map <<< map) (\x -> x.hp)


Use operator to clean up gen spec

Use operator to clean up gen spec

module Test.Spec.GenSpec (
  genSpec
, genTransSpec
)
where

import Prelude
import Data.Tuple (Tuple(..))
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.State (State(), evalState)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException, catchException
                                   , message)
import qualified Text.Parsing.Parser as P

import Docopt
import Docopt.Spec.Parser.Usage (Usage(..))
import qualified Docopt.Spec.Parser.Usage as Usage
import qualified Docopt.Spec.Parser.Lexer as Lexer
import qualified Docopt.Spec.Parser.Scanner as Scanner
import Docopt.Gen (genParser, runParser)
import Docopt.Gen.Lexer (lex)
import Docopt.Spec.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

-- short hand to create a Command
co :: String -> Argument
co = Command

-- short hand to create a Positional argument
pos :: String -> Boolean -> Argument
pos = Positional

-- short hand to create a end-of-arguments marker
eoa :: Argument
eoa = EOA

-- short hand to create an Option argument
opt' :: Flag
      -> Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
opt' f n = Option (Just f) (Just n)

opt_ :: Flag
      -> Name
      -> Argument
opt_ f n = opt' f n Nothing false

optR_ :: Flag
      -> Name
      -> Argument
optR_ f n = opt' f n Nothing true

opt :: Flag
    -> Name
    -> OptionArgument
    -> Argument
opt f n a = opt' f n (Just a) false

optR :: Flag
     -> Name
     -> OptionArgument
     -> Argument
optR f n a = opt' f n (Just a) true

sopt :: Flag
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
sopt f = Option (Just f) Nothing

lopt :: Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
lopt name = Option Nothing (Just name)

-- short hand to create a group
gr :: Boolean -> IsRepeatable -> (Array (Array Argument)) -> Argument
gr b r xs = Group b (toList $ br <$> xs) r

-- short hand to create a optional group
gro :: IsRepeatable -> (Array (Array Argument)) -> Argument
gro = gr true

-- short hand to create a required group
grr :: IsRepeatable -> (Array (Array Argument)) -> Argument
grr = gr false

-- short hand to create a whole branch
br :: (Array Argument) -> Branch
br xs = Branch (toList xs)

oa :: String -> Value -> OptionArgument
oa n v = OptionArgument n (Just v)

oa_ :: String -> OptionArgument
oa_ n = OptionArgument n Nothing

type Input    = Array String
type Output   = Map Argument Value
data Test = Test (Array Argument) (Array Case)
data Case = Case Input (Either String Output)

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Input -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Input -> String -> Case
fail i e = Case i (Left e)

(#=) = Tuple
infixr 0 #=

genSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = co    "foo"
      opt_f_foo_FOZ__r = optR  'f' "foo" (oa_ "FOZ")
      opt_q_qux___r    = optR_ 'q' "qux"
      opt_b_baz        = opt   'b' "baz"   (oa "BAZ" $ StringValue "ax")
      opt_o_out        = opt_  'o' "out"
      opt_i_input      = opt_  'i' "input"
      pos_arg_r        = pos    "qux" true
      cmd_baz          = co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ pos_arg_r #= ArrayValue [
                            StringValue "a"
                          , StringValue "b"
                          , StringValue "c"
                          ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ pos_arg_r #= ArrayValue [
                              StringValue "a"
                            , StringValue "b"
                            , StringValue "c"
                            ]
            , eoa #= ArrayValue []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ pos_arg_r #= ArrayValue [
                              StringValue "a"
                            , StringValue "b"
                            , StringValue "c"
                            ]
            , eoa #= ArrayValue [
                        StringValue "--"
                      , StringValue "--"
                      ]
            ]
        ]

    , test
        [ grr false [] ]
        [ pass [] [] ]

    , test
        [ gro false [] ]
        [ pass [] [] ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ opt 'i' "input" (oa_ "FILE") #= (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") #= (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") #= (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            grr false [[
              opt 'i' "input" (oa_ "FILE")
            ]]
          , opt 'r' "redirect" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   #= (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") #= (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   #= (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   #= (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") #= (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   #= (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          , pos "env" false
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") #= (StringValue "bar")
            , pos "env" false               #= (StringValue "x")
            , opt 'o' "output" (oa_ "FILE") #= (StringValue "bar") ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ cmd_foo          #= BoolValue true
            , opt_o_out        #= BoolValue true
            , opt_i_input      #= BoolValue true
            , opt_q_qux___r    #= ArrayValue [ BoolValue true ]
            , opt_f_foo_FOZ__r #= ArrayValue [ StringValue "ox" ]
            , cmd_baz          #= BoolValue true
            -- should have added default value that was not provided above:
            , opt_b_baz        #= StringValue "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ cmd_foo       #= BoolValue true
            , opt_o_out     #= BoolValue true
            , opt_q_qux___r #= ArrayValue [
                                  BoolValue true
                                , BoolValue true
                                , BoolValue true
                                ]
            , opt_f_foo_FOZ__r #= ArrayValue [StringValue "ox"]
            , opt_b_baz        #= StringValue "ax"
            , opt_i_input      #= BoolValue true
            , cmd_baz          #= BoolValue true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ cmd_foo          #= BoolValue true
            , opt_q_qux___r    #= ArrayValue [
                                        BoolValue true
                                      , BoolValue true
                                     ]
            , opt_o_out        #= BoolValue true
            , opt_i_input      #= BoolValue true
            , opt_b_baz        #= StringValue "ax"
            , opt_f_foo_FOZ__r #= ArrayValue [StringValue "ox"]
            , cmd_baz          #= BoolValue true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ cmd_foo          #= BoolValue true
            , opt_b_baz        #= StringValue "ax"
            , opt_o_out        #= BoolValue true
            , opt_f_foo_FOZ__r #= ArrayValue [StringValue "ox"]
            , opt_i_input      #= BoolValue true
            , cmd_baz          #= BoolValue true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ cmd_foo     #= BoolValue true
            , opt_o_out   #= BoolValue true
            , opt_i_input #= BoolValue true
            , opt_b_baz   #= StringValue "ax"
            , cmd_baz     #= BoolValue true
            -- should have added default value that was not provided above:
            , opt_b_baz  #= StringValue "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  (\e -> prettyPrintOutput e)
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOutput :: Output -> String
      prettyPrintOutput expected = ("\n\t" ++) $ intercalate "\n\t" $
                      (Map.toList expected) <#> \(Tuple arg val) ->
                        prettyPrintArg arg ++ ": " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Input
                            -> Either String Output
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              runParser
                (toList argv)
                (genParser $ singleton $ Application $ singleton $ br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOutput r
                  else return unit)
              expected

genTransSpec = \_ ->
  describe "The output transformer" do
    it "..." do
      pure unit

module Test.Spec.GenSpec (
  genSpec
, genTransSpec
)
where

import Prelude
import Data.Tuple (Tuple(..))
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.State (State(), evalState)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException, catchException
                                   , message)
import qualified Text.Parsing.Parser as P

import Docopt
import Docopt.Spec.Parser.Usage (Usage(..))
import qualified Docopt.Spec.Parser.Usage as Usage
import qualified Docopt.Spec.Parser.Lexer as Lexer
import qualified Docopt.Spec.Parser.Scanner as Scanner
import Docopt.Gen (genParser, runParser)
import Docopt.Gen.Lexer (lex)
import Docopt.Spec.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

-- short hand to create a Command
co :: String -> Argument
co = Command

-- short hand to create a Positional argument
pos :: String -> Boolean -> Argument
pos = Positional

-- short hand to create a end-of-arguments marker
eoa :: Argument
eoa = EOA

-- short hand to create an Option argument
opt' :: Flag
      -> Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
opt' f n = Option (Just f) (Just n)

opt_ :: Flag
      -> Name
      -> Argument
opt_ f n = opt' f n Nothing false

optR_ :: Flag
      -> Name
      -> Argument
optR_ f n = opt' f n Nothing true

opt :: Flag
    -> Name
    -> OptionArgument
    -> Argument
opt f n a = opt' f n (Just a) false

optR :: Flag
     -> Name
     -> OptionArgument
     -> Argument
optR f n a = opt' f n (Just a) true

sopt :: Flag
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
sopt f = Option (Just f) Nothing

lopt :: Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
lopt name = Option Nothing (Just name)

-- short hand to create a group
gr :: Boolean -> IsRepeatable -> (Array (Array Argument)) -> Argument
gr b r xs = Group b (toList $ br <$> xs) r

-- short hand to create a optional group
gro :: IsRepeatable -> (Array (Array Argument)) -> Argument
gro = gr true

-- short hand to create a required group
grr :: IsRepeatable -> (Array (Array Argument)) -> Argument
grr = gr false

-- short hand to create a whole branch
br :: (Array Argument) -> Branch
br xs = Branch (toList xs)

oa :: String -> Value -> OptionArgument
oa n v = OptionArgument n (Just v)

oa_ :: String -> OptionArgument
oa_ n = OptionArgument n Nothing

type Input    = Array String
type Output   = Map Argument Value
data Test = Test (Array Argument) (Array Case)
data Case = Case Input (Either String Output)

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Input -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Input -> String -> Case
fail i e = Case i (Left e)

(//) = Tuple

genSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = co    "foo"
      opt_f_foo_FOZ__r = optR  'f' "foo" (oa_ "FOZ")
      opt_q_qux___r    = optR_ 'q' "qux"
      opt_b_baz        = opt   'b' "baz"   (oa "BAZ" $ StringValue "ax")
      opt_o_out        = opt_  'o' "out"
      opt_i_input      = opt_  'i' "input"
      pos_arg_r        = pos    "qux" true
      cmd_baz          = co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            , Tuple eoa (ArrayValue [])
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            , Tuple eoa (ArrayValue [
                          StringValue "--"
                        , StringValue "--"
                        ])
            ]
        ]

    , test
        [ grr false [] ]
        [ pass [] [] ]

    , test
        [ gro false [] ]
        [ pass [] [] ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ opt 'i' "input" (oa_ "FILE") // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            grr false [[
              opt 'i' "input" (oa_ "FILE")
            ]]
          , opt 'r' "redirect" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   // (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   // (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   // (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          , pos "env" false
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , pos "env" false               // (StringValue "x")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [ BoolValue true ])
            , Tuple opt_f_foo_FOZ__r (ArrayValue [ StringValue "ox" ])
            , Tuple cmd_baz          (BoolValue true)
            -- should have added default value that was not provided above:
            , Tuple opt_b_baz        (StringValue "ax")
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [
                                        BoolValue true
                                      , BoolValue true
                                      , BoolValue true
                                     ])
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_i_input      (BoolValue true)
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [
                                        BoolValue true
                                      , BoolValue true
                                     ])
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple opt_i_input      (BoolValue true)
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple cmd_baz          (BoolValue true)
            -- should have added default value that was not provided above:
            , Tuple opt_b_baz        (StringValue "ax")
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  (\e -> prettyPrintOutput e)
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOutput :: Output -> String
      prettyPrintOutput expected = ("\n\t" ++) $ intercalate "\n\t" $
                      (Map.toList expected) <#> \(Tuple arg val) ->
                        prettyPrintArg arg ++ ": " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Input
                            -> Either String Output
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              runParser
                (toList argv)
                (genParser $ singleton $ Application $ singleton $ br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOutput r
                  else return unit)
              expected

genTransSpec = \_ ->
  describe "The output transformer" do
    it "..." do
      pure unit


Fix an issue with type synonyms

Fix an issue with type synonyms

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.BindingGroups
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- This module implements the desugaring pass which creates binding groups from sets of
-- mutually-recursive value declarations and mutually-recursive type declarations.
--
-----------------------------------------------------------------------------

module Language.PureScript.Sugar.BindingGroups (
    createBindingGroups,
    createBindingGroupsModule,
    collapseBindingGroups,
    collapseBindingGroupsModule
  ) where

import Data.Array
import Data.Maybe
import Data.Either
import Data.Foldable (all, find)
import Data.Traversable

import Data.Graph

import Data.Tuple
import Data.Tuple3
import Data.Tuple5

import Control.Apply

import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Environment
import Language.PureScript.Errors

-- |
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]
createBindingGroupsModule = traverse $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps

-- |
-- Collapse all binding groups in a module to individual declarations
--
collapseBindingGroupsModule :: [Module] -> [Module]
collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps

-- |
-- Replace all sets of mutually-recursive declarations with binding groups
--
createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
createBindingGroups moduleName ds = do
  values <- traverse (createBindingGroupsForValue moduleName) $ filter isValueDecl ds
  let dataDecls = filter isDataDecl ds
      declNamed pn =
        case find (\d -> getProperName d == pn) dataDecls of
          Just d -> d
      dataVerts = map getProperName dataDecls
      dataEdges = do d1 <- dataDecls
                     d2 <- usedProperNames moduleName d1 `intersect` dataVerts
                     return $ Edge (getProperName d1) d2
  dataBindingGroupDecls <- traverse toDataBindingGroup $ scc' getProperName declNamed $ Graph dataDecls dataEdges
  let valueVerts = map getIdent values
      valueNamed ident =
        case find (\v -> getIdent v == ident) values of
          Just v -> v
      valueEdges = do val1 <- values
                      val2 <- usedIdents moduleName val1 `intersect` valueVerts
                      return $ Edge (getIdent val1) val2
      bindingGroupDecls = map toBindingGroup $ scc' getIdent valueNamed $ Graph values valueEdges
  return $ filter isImportDecl ds ++
           filter isExternDataDecl ds ++
           filter isExternInstanceDecl ds ++
           dataBindingGroupDecls ++
           filter isTypeClassDeclaration ds ++
           filter isFixityDecl ds ++
           filter isExternDecl ds ++
           bindingGroupDecls

createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration
createBindingGroupsForValue moduleName =
  case everywhereOnValuesTopDownM return go return of
    Tuple3 f _ _ -> f
  where
  go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val
  go other = return other

-- |
-- Collapse all binding groups to individual declarations
--
collapseBindingGroups :: [Declaration] -> [Declaration]
collapseBindingGroups ds =
  case everywhereOnValues id collapseBindingGroupsForValue id of
    Tuple3 f _ _ -> map f (concatMap go ds)
  where
  go (DataBindingGroupDeclaration ds) = ds
  go (BindingGroupDeclaration ds) = map (\(Tuple3 ident nameKind val) -> ValueDeclaration ident nameKind [] Nothing val) ds
  go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
  go other = [other]

collapseBindingGroupsForValue :: Value -> Value
collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
collapseBindingGroupsForValue other = other

usedIdents :: ModuleName -> Declaration -> [Ident]
usedIdents moduleName =
  case everythingOnValues (++) (const []) usedNames (const []) (const []) (const []) of
    Tuple5 f _ _ _ _ -> nub <<< f
  where
  usedNames :: Value -> [Ident]
  usedNames (Var (Qualified Nothing name)) = [name]
  usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
  usedNames _ = []

usedProperNames :: ModuleName -> Declaration -> [ProperName]
usedProperNames moduleName =
  case accumTypes (everythingOnTypes (++) usedNames) of
    Tuple5 f _ _ _ _ -> nub <<< f
  where
  usedNames :: Type -> [ProperName]
  usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
    case qual of
      Tuple (Qualified (Just moduleName') name) _ | moduleName == moduleName' -> Just name
      _ -> Nothing
  usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
  usedNames _ = []

getIdent :: Declaration -> Ident
getIdent (ValueDeclaration ident _ _ _ _) = ident
getIdent (PositionedDeclaration _ d) = getIdent d
getIdent _ = theImpossibleHappened "Expected ValueDeclaration"

getProperName :: Declaration -> ProperName
getProperName (DataDeclaration pn _ _) = pn
getProperName (TypeSynonymDeclaration pn _ _) = pn
getProperName (PositionedDeclaration _ d) = getProperName d
getProperName _ = theImpossibleHappened "Expected DataDeclaration"

toBindingGroup :: [Declaration] -> Declaration
toBindingGroup [d] = d
toBindingGroup ds' = BindingGroupDeclaration $ map fromValueDecl ds'

toDataBindingGroup :: [Declaration] -> Either ErrorStack Declaration
toDataBindingGroup [d] = return d
{-
toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
  Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
  _ -> return d
-}
toDataBindingGroup ds' | all (isJust <<< isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing
toDataBindingGroup ds' = return $ DataBindingGroupDeclaration ds'

isTypeSynonym :: Declaration -> Maybe ProperName
isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
isTypeSynonym _ = Nothing

fromValueDecl :: Declaration -> Tuple3 Ident NameKind Value
fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = Tuple3 ident nameKind val
fromValueDecl (ValueDeclaration _ _ _ _ _) = theImpossibleHappened "Binders should have been desugared"
fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
fromValueDecl _ = theImpossibleHappened "Expected ValueDeclaration"

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.BindingGroups
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- This module implements the desugaring pass which creates binding groups from sets of
-- mutually-recursive value declarations and mutually-recursive type declarations.
--
-----------------------------------------------------------------------------

module Language.PureScript.Sugar.BindingGroups (
    createBindingGroups,
    createBindingGroupsModule,
    collapseBindingGroups,
    collapseBindingGroupsModule
  ) where

import Data.Array
import Data.Maybe
import Data.Either
import Data.Foldable (all, find)
import Data.Traversable

import Data.Graph

import Data.Tuple
import Data.Tuple3
import Data.Tuple5

import Control.Apply

import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Environment
import Language.PureScript.Errors

-- |
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]
createBindingGroupsModule = traverse $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps

-- |
-- Collapse all binding groups in a module to individual declarations
--
collapseBindingGroupsModule :: [Module] -> [Module]
collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps

-- |
-- Replace all sets of mutually-recursive declarations with binding groups
--
createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
createBindingGroups moduleName ds = do
  values <- traverse (createBindingGroupsForValue moduleName) $ filter isValueDecl ds
  let dataDecls = filter isDataDecl ds
      declNamed pn =
        case find (\d -> getProperName d == pn) ds of
          Just d -> d
      dataVerts = map getProperName dataDecls
      dataEdges = do d1 <- dataDecls
                     d2 <- usedProperNames moduleName d1 `intersect` dataVerts
                     return $ Edge (getProperName d1) d2
  dataBindingGroupDecls <- traverse toDataBindingGroup $ scc' getProperName declNamed $ Graph dataDecls dataEdges
  let valueVerts = map getIdent values
      valueNamed ident =
        case find (\v -> getIdent v == ident) values of
          Just v -> v
      valueEdges = do val1 <- values
                      val2 <- usedIdents moduleName val1 `intersect` valueVerts
                      return $ Edge (getIdent val1) val2
      bindingGroupDecls = map toBindingGroup $ scc' getIdent valueNamed $ Graph values valueEdges
  return $ filter isImportDecl ds ++
           filter isExternDataDecl ds ++
           filter isExternInstanceDecl ds ++
           dataBindingGroupDecls ++
           filter isTypeClassDeclaration ds ++
           filter isFixityDecl ds ++
           filter isExternDecl ds ++
           bindingGroupDecls

createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration
createBindingGroupsForValue moduleName =
  case everywhereOnValuesTopDownM return go return of
    Tuple3 f _ _ -> f
  where
  go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val
  go other = return other

-- |
-- Collapse all binding groups to individual declarations
--
collapseBindingGroups :: [Declaration] -> [Declaration]
collapseBindingGroups ds =
  case everywhereOnValues id collapseBindingGroupsForValue id of
    Tuple3 f _ _ -> map f (concatMap go ds)
  where
  go (DataBindingGroupDeclaration ds) = ds
  go (BindingGroupDeclaration ds) = map (\(Tuple3 ident nameKind val) -> ValueDeclaration ident nameKind [] Nothing val) ds
  go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
  go other = [other]

collapseBindingGroupsForValue :: Value -> Value
collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
collapseBindingGroupsForValue other = other

usedIdents :: ModuleName -> Declaration -> [Ident]
usedIdents moduleName =
  case everythingOnValues (++) (const []) usedNames (const []) (const []) (const []) of
    Tuple5 f _ _ _ _ -> nub <<< f
  where
  usedNames :: Value -> [Ident]
  usedNames (Var (Qualified Nothing name)) = [name]
  usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
  usedNames _ = []

usedProperNames :: ModuleName -> Declaration -> [ProperName]
usedProperNames moduleName =
  case accumTypes (everythingOnTypes (++) usedNames) of
    Tuple5 f _ _ _ _ -> nub <<< f
  where
  usedNames :: Type -> [ProperName]
  usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
    case qual of
      Tuple (Qualified (Just moduleName') name) _ | moduleName == moduleName' -> Just name
      _ -> Nothing
  usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
  usedNames _ = []

getIdent :: Declaration -> Ident
getIdent (ValueDeclaration ident _ _ _ _) = ident
getIdent (PositionedDeclaration _ d) = getIdent d
getIdent _ = theImpossibleHappened "Expected ValueDeclaration"

getProperName :: Declaration -> ProperName
getProperName (DataDeclaration pn _ _) = pn
getProperName (TypeSynonymDeclaration pn _ _) = pn
getProperName (PositionedDeclaration _ d) = getProperName d
getProperName _ = theImpossibleHappened "Expected DataDeclaration"

toBindingGroup :: [Declaration] -> Declaration
toBindingGroup [d] = d
toBindingGroup ds' = BindingGroupDeclaration $ map fromValueDecl ds'

toDataBindingGroup :: [Declaration] -> Either ErrorStack Declaration
toDataBindingGroup [d] = return d
{-
toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
  Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
  _ -> return d
-}
toDataBindingGroup ds' | all (isJust <<< isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing
toDataBindingGroup ds' = return $ DataBindingGroupDeclaration ds'

isTypeSynonym :: Declaration -> Maybe ProperName
isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
isTypeSynonym _ = Nothing

fromValueDecl :: Declaration -> Tuple3 Ident NameKind Value
fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = Tuple3 ident nameKind val
fromValueDecl (ValueDeclaration _ _ _ _ _) = theImpossibleHappened "Binders should have been desugared"
fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
fromValueDecl _ = theImpossibleHappened "Expected ValueDeclaration"