fix infinite loader

fix infinite loader

module Components.BooksDirectory (booksDirectory) where

import Common.Data.BooksDirectoryInfo (BooksDirectoryInfo(BooksDirectoryInfo), booksDirectoryInfoId, defaultBooksDirectoryInfo)
import Common.OneDriveApi (ItemReference(..), OneDriveItem(..), getOneDriveItem)
import Common.React (maybeProps, mapProps)
import Components.AjaxLoader.AjaxLoader as AjaxLoader
import Components.ChooseDirectoryModal as ChooseDirectoryModal
import Components.OneDriveFileTree as FileTree
import Components.Wrappers.Button as Button
import Components.Wrappers.ControlLabel as ControlLabel
import Components.Wrappers.FormControl as FormControl
import Components.Wrappers.FormGroup as FormGroup
import Control.Coroutine (cotransform)
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Maybe.Trans (runMaybeT)
import Control.Monad.Trans (lift)
import Control.Error.Util (hoistMaybe)
import Data.Foldable (fold)
import Data.Lens (LensP, over, lens, PrismP, prism', set, _Just, (^.))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String as S
import Data.Tuple (Tuple(..))
import Libs.PouchDB (POUCHDB, PouchDB, PouchDBAff)
import Libs.PouchDB.Json (tryGetJson, putJson)
import Network.HTTP.Affjax (AJAX)
import Prelude
import React (ReactElement, ReactClass, createElement, createClass, transformState, getProps) as R
import React.DOM (text, form) as R
import Thermite as T

type Props =
  { onedriveToken :: String
  , db :: Maybe PouchDB
  }

type State =
  { booksDir :: Maybe DirectoryInfo
  , readDir :: Maybe DirectoryInfo
  , stateLoaded :: Boolean
  , booksModal :: ChooseDirectoryModal.State
  , readModal :: ChooseDirectoryModal.State
  }

booksDir :: LensP State (Maybe DirectoryInfo)
booksDir =
  lens _.booksDir (_ { booksDir = _ })

readDir :: LensP State (Maybe DirectoryInfo)
readDir =
  lens _.readDir (_ { readDir = _ })

stateLoaded :: LensP State Boolean
stateLoaded =
  lens _.stateLoaded (_ { stateLoaded = _ })

booksModal :: LensP State ChooseDirectoryModal.State
booksModal =
  lens _.booksModal (_ { booksModal = _ })

readModal :: LensP State ChooseDirectoryModal.State
readModal =
  lens _.readModal (_ { readModal = _ })

type DirectoryInfo =
  { itemId :: Maybe String
  , path :: String
  }

itemId_ :: LensP DirectoryInfo (Maybe String)
itemId_ =
  lens _.itemId (_ { itemId = _ })

defaultState :: State
defaultState =
  { stateLoaded: false
  , booksDir: Nothing
  , readDir: Nothing
  , booksModal: ChooseDirectoryModal.defaultState
  , readModal: ChooseDirectoryModal.defaultState
  }

data Action
  = BooksModalAction ChooseDirectoryModal.Action
  | ReadModalAction ChooseDirectoryModal.Action
  | Save

booksModalAction :: PrismP Action ChooseDirectoryModal.Action
booksModalAction =
  prism' BooksModalAction getModal
  where
    getModal (BooksModalAction x) = Just x
    getModal _ = Nothing

readModalAction :: PrismP Action ChooseDirectoryModal.Action
readModalAction =
  prism' ReadModalAction getModel
  where
    getModel (ReadModalAction x) = Just x
    getModel _ = Nothing

spec :: forall eff. T.Spec (ajax :: AJAX, pouchdb :: POUCHDB, err :: EXCEPTION | eff) State Props Action
spec =
  fold
  [ T.withState $ \st ->
                    if not st.stateLoaded
                    then
                      AjaxLoader.spec
                    else
                      wrapForm $ booksDirectoryGroup <> readDirectoryGroup <> saveButton
  , T.simpleSpec performAction T.defaultRender
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus booksModal booksModalAction ChooseDirectoryModal.spec
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus readModal readModalAction ChooseDirectoryModal.spec
  ]
  where
    booksDirectoryGroup =
      wrapFormGroup (Just "booksDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Books directory" ]
          , renderDirectoryInfo "Books directory placeholder" s.booksDir
          , Button.button { bsStyle: "link", onClick: dispatch (BooksModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    readDirectoryGroup =
      wrapFormGroup (Just "readDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Read directory" ]
          , renderDirectoryInfo "Read directory placeholder" s.readDir
          , Button.button { bsStyle: "link", onClick: dispatch (ReadModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    saveButton =
      T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ _ _ =
          [ Button.button { type: "submit", onClick: dispatch Save } [ R.text "Save" ] ]

    performAction Save props state =
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        let
          booksItemId =
            state ^. (booksDir <<< _Just <<< itemId_)
          readItemId =
            state ^. (readDir <<< _Just <<< itemId_)
        lift $ lift $ updateBooksDirectoryIfNeeded db booksItemId readItemId
    performAction (BooksModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props booksDir itemId
        _ ->
          pure unit
    performAction (ReadModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props readDir itemId
        _ ->
          pure unit
    performAction _ _ _ =
      pure unit

    updateItemId props dirSetter itemId = do
      void $ cotransform $ set dirSetter Nothing <<< set stateLoaded false
      dir <- lift $ getDirectoryInfo props.onedriveToken itemId
      void $ cotransform $ set dirSetter (Just dir) <<< set stateLoaded true

    tryGetChooseDirectoryModalProps p = do
      db <- p.db
      pure { onedriveToken: p.onedriveToken
           , db
           }

    renderDirectoryInfo placeholder maybeDirInfo =
      FormControl.formControlStatic {} [ R.text (maybe placeholder _.path maybeDirInfo) ]

wrapForm :: forall eff state props action. T.Spec eff state props action -> T.Spec eff state props action
wrapForm =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      [ R.form
        [ ]
        (origRender dispatch p s c)
      ]

wrapFormGroup :: forall eff state props action. Maybe String -> T.Spec eff state props action -> T.Spec eff state props action
wrapFormGroup controlId =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      let
        fg =
          maybe (FormGroup.formGroup {}) (\c -> FormGroup.formGroup { controlId: c }) controlId
      in
        [ fg $ origRender dispatch p s c ]

reactClass :: R.ReactClass Props
reactClass =
  R.createClass reactSpec.spec { componentDidMount = componentDidMount }
  where
    reactSpec =
      T.createReactSpec spec defaultState

    componentDidMount this = void $ launchAff $ do
      props <- liftEff $ R.getProps this
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        BooksDirectoryInfo info <- lift $ getBooksDirectoryInfo db
        dir1 <- lift $ getDirectoryInfo props.onedriveToken info.booksItemId
        dir2 <- lift $ getDirectoryInfo props.onedriveToken info.readItemId
        liftEff $ R.transformState this (_ { booksDir = Just dir1, readDir = Just dir2, stateLoaded = true })

booksDirectory :: Props -> R.ReactElement
booksDirectory props =
  R.createElement reactClass props []

getDirectoryInfo :: forall e. String -> Maybe String -> Aff (ajax :: AJAX | e) DirectoryInfo
getDirectoryInfo token itemId = do
  item <- getItem <$> getOneDriveItem token itemId
  let parentPath = fromMaybe "" (getPath <$> item.parentReference)
  pure { itemId
       , path : parentPath <> "/" <> item.name
       }
  where
    getItem (OneDriveItem item) = item
    getPath (ItemReference reference) =
      let
        idx = S.indexOf ":" reference.path
      in
       maybe reference.path (\i -> S.drop (i + 1) reference.path) idx

getBooksDirectoryInfo :: forall e. PouchDB -> PouchDBAff e BooksDirectoryInfo
getBooksDirectoryInfo db =
  fromMaybe defaultBooksDirectoryInfo <$> tryGetJson db booksDirectoryInfoId

updateBooksDirectoryIfNeeded :: forall e. PouchDB -> Maybe String -> Maybe String -> PouchDBAff e Unit
updateBooksDirectoryIfNeeded db booksItemId readItemId = do
  BooksDirectoryInfo current <- getBooksDirectoryInfo db
  when (current.booksItemId /= booksItemId || current.readItemId /= readItemId) $
    putJson db $ BooksDirectoryInfo current { booksItemId = booksItemId
                                            , readItemId = readItemId
                                            }

module Components.BooksDirectory (booksDirectory) where

import Common.Data.BooksDirectoryInfo (BooksDirectoryInfo(BooksDirectoryInfo), booksDirectoryInfoId, defaultBooksDirectoryInfo)
import Common.OneDriveApi (ItemReference(..), OneDriveItem(..), getOneDriveItem)
import Common.React (maybeProps, mapProps)
import Components.AjaxLoader.AjaxLoader as AjaxLoader
import Components.ChooseDirectoryModal as ChooseDirectoryModal
import Components.OneDriveFileTree as FileTree
import Components.Wrappers.Button as Button
import Components.Wrappers.ControlLabel as ControlLabel
import Components.Wrappers.FormControl as FormControl
import Components.Wrappers.FormGroup as FormGroup
import Control.Coroutine (cotransform)
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Maybe.Trans (runMaybeT)
import Control.Monad.Trans (lift)
import Control.Error.Util (hoistMaybe)
import Data.Foldable (fold)
import Data.Lens (LensP, over, lens, PrismP, prism', set, _Just, (^.))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String as S
import Data.Tuple (Tuple(..))
import Libs.PouchDB (POUCHDB, PouchDB, PouchDBAff)
import Libs.PouchDB.Json (tryGetJson, putJson)
import Network.HTTP.Affjax (AJAX)
import Prelude
import React (ReactElement, ReactClass, createElement, createClass, transformState, getProps) as R
import React.DOM (text, form) as R
import Thermite as T

type Props =
  { onedriveToken :: String
  , db :: Maybe PouchDB
  }

type State =
  { booksDir :: Maybe DirectoryInfo
  , readDir :: Maybe DirectoryInfo
  , stateLoaded :: Boolean
  , booksModal :: ChooseDirectoryModal.State
  , readModal :: ChooseDirectoryModal.State
  }

booksDir :: LensP State (Maybe DirectoryInfo)
booksDir =
  lens _.booksDir (_ { booksDir = _ })

readDir :: LensP State (Maybe DirectoryInfo)
readDir =
  lens _.readDir (_ { readDir = _ })

stateLoaded :: LensP State Boolean
stateLoaded =
  lens _.stateLoaded (_ { stateLoaded = _ })

booksModal :: LensP State ChooseDirectoryModal.State
booksModal =
  lens _.booksModal (_ { booksModal = _ })

readModal :: LensP State ChooseDirectoryModal.State
readModal =
  lens _.readModal (_ { readModal = _ })

type DirectoryInfo =
  { itemId :: Maybe String
  , path :: String
  }

itemId_ :: LensP DirectoryInfo (Maybe String)
itemId_ =
  lens _.itemId (_ { itemId = _ })

defaultState :: State
defaultState =
  { stateLoaded: false
  , booksDir: Nothing
  , readDir: Nothing
  , booksModal: ChooseDirectoryModal.defaultState
  , readModal: ChooseDirectoryModal.defaultState
  }

data Action
  = BooksModalAction ChooseDirectoryModal.Action
  | ReadModalAction ChooseDirectoryModal.Action
  | Save

booksModalAction :: PrismP Action ChooseDirectoryModal.Action
booksModalAction =
  prism' BooksModalAction getModal
  where
    getModal (BooksModalAction x) = Just x
    getModal _ = Nothing

readModalAction :: PrismP Action ChooseDirectoryModal.Action
readModalAction =
  prism' ReadModalAction getModel
  where
    getModel (ReadModalAction x) = Just x
    getModel _ = Nothing

spec :: forall eff. T.Spec (ajax :: AJAX, pouchdb :: POUCHDB, err :: EXCEPTION | eff) State Props Action
spec =
  fold
  [ T.withState $ \st ->
                    if not st.stateLoaded
                    then
                      AjaxLoader.spec
                    else
                      wrapForm $ booksDirectoryGroup <> readDirectoryGroup <> saveButton
  , T.simpleSpec performAction T.defaultRender
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus booksModal booksModalAction ChooseDirectoryModal.spec
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus readModal readModalAction ChooseDirectoryModal.spec
  ]
  where
    booksDirectoryGroup =
      wrapFormGroup (Just "booksDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Books directory" ]
          , renderDirectoryInfo "Books directory placeholder" s.booksDir
          , Button.button { bsStyle: "link", onClick: dispatch (BooksModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    readDirectoryGroup =
      wrapFormGroup (Just "readDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Read directory" ]
          , renderDirectoryInfo "Read directory placeholder" s.readDir
          , Button.button { bsStyle: "link", onClick: dispatch (ReadModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    saveButton =
      T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ _ _ =
          [ Button.button { type: "submit", onClick: dispatch Save } [ R.text "Save" ] ]

    performAction Save props state =
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        let
          booksItemId =
            state ^. (booksDir <<< _Just <<< itemId_)
          readItemId =
            state ^. (readDir <<< _Just <<< itemId_)
        lift $ lift $ updateBooksDirectoryIfNeeded db booksItemId readItemId
    performAction (BooksModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props booksDir itemId
        _ ->
          pure unit
    performAction (ReadModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props readDir itemId
        _ ->
          pure unit
    performAction _ _ _ =
      pure unit

    updateItemId props dirSetter itemId = do
      void $ cotransform $ set dirSetter Nothing <<< set stateLoaded false
      dir <- lift $ getDirectoryInfo props.onedriveToken itemId
      void $ cotransform $ set dirSetter (Just dir) <<< set stateLoaded true

    tryGetChooseDirectoryModalProps p = do
      db <- p.db
      pure { onedriveToken: p.onedriveToken
           , db
           }

    renderDirectoryInfo placeholder maybeDirInfo =
      FormControl.formControlStatic {} [ R.text (maybe placeholder _.path maybeDirInfo) ]

wrapForm :: forall eff state props action. T.Spec eff state props action -> T.Spec eff state props action
wrapForm =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      [ R.form
        [ ]
        (origRender dispatch p s c)
      ]

wrapFormGroup :: forall eff state props action. Maybe String -> T.Spec eff state props action -> T.Spec eff state props action
wrapFormGroup controlId =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      let
        fg =
          maybe (FormGroup.formGroup {}) (\c -> FormGroup.formGroup { controlId: c }) controlId
      in
        [ fg $ origRender dispatch p s c ]

reactClass :: R.ReactClass Props
reactClass =
  R.createClass reactSpec.spec { componentDidMount = componentDidMount }
  where
    reactSpec =
      T.createReactSpec spec defaultState

    componentDidMount this = void $ launchAff $ do
      props <- liftEff $ R.getProps this
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        BooksDirectoryInfo info <- lift (tryGetJson db booksDirectoryInfoId) >>= hoistMaybe
        dir1 <- lift $ getDirectoryInfo props.onedriveToken info.booksItemId
        dir2 <- lift $ getDirectoryInfo props.onedriveToken info.readItemId
        liftEff $ R.transformState this (_ { booksDir = Just dir1, readDir = Just dir2, stateLoaded = true })

booksDirectory :: Props -> R.ReactElement
booksDirectory props =
  R.createElement reactClass props []

getDirectoryInfo :: forall e. String -> Maybe String -> Aff (ajax :: AJAX | e) DirectoryInfo
getDirectoryInfo token itemId = do
  item <- getItem <$> getOneDriveItem token itemId
  let parentPath = fromMaybe "" (getPath <$> item.parentReference)
  pure { itemId
       , path : parentPath <> "/" <> item.name
       }
  where
    getItem (OneDriveItem item) = item
    getPath (ItemReference reference) =
      let
        idx = S.indexOf ":" reference.path
      in
       maybe reference.path (\i -> S.drop (i + 1) reference.path) idx

updateBooksDirectoryIfNeeded :: forall e. PouchDB -> Maybe String -> Maybe String -> PouchDBAff e Unit
updateBooksDirectoryIfNeeded db booksItemId readItemId = do
  BooksDirectoryInfo current <- fromMaybe defaultBooksDirectoryInfo <$> tryGetJson db booksDirectoryInfoId
  when (current.booksItemId /= booksItemId || current.readItemId /= readItemId) $
    putJson db $ BooksDirectoryInfo current { booksItemId = booksItemId
                                            , readItemId = readItemId
                                            }


Update Value.purs

Update Value.purs

Add support for toSQLValue for list an array

module Database.PostgreSQL.Value where

import Control.Monad.Eff (kind Effect)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.DateTime.Instant (Instant)
import Data.Either (Either)
import Data.Foreign (Foreign, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, toForeign, unsafeFromForeign)
import Data.List (List)
import Data.List as List
import Data.Array(fromFoldable)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Prelude

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = toForeign

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = toForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = toForeign

instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = toForeign

instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

instance toSQLValueArray :: (ToSQLValue a) => ToSQLValue (Array a) where
    toSQLValue = toForeign <<< map toSQLValue

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

instance toSQLValueList :: (ToSQLValue a) => ToSQLValue (List a) where
    toSQLValue = toForeign <<< fromFoldable <<< map toSQLValue

instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = toForeign

instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = id

instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean

module Database.PostgreSQL.Value where

import Control.Monad.Eff (kind Effect)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.DateTime.Instant (Instant)
import Data.Either (Either)
import Data.Foreign (Foreign, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, toForeign, unsafeFromForeign)
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Prelude

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = toForeign

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = toForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = toForeign

instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = toForeign

instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = toForeign

instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = id

instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean


changed types of parser to ParserT, refactored some parsers

module Parser where

import Prelude (class Show, show, Unit, void, class Monad, bind, return, ($), (<$>), (<<<), (+), (*), (++), id, flip, negate)
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, toList, concat, elemIndex, fromList)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)

import Control.Alt ((<|>))
import Control.Apply ((<*), (*>), lift2)
import Control.Lazy (fix)
import Control.Monad.State (runState)
import Data.Tuple (fst)
import Data.Either (Either(..))

import Text.Parsing.Parser (ParseError, ParserT, PState(..), runParser, runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf, anyChar)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Qual(..), ExprQual, Op(..))
import IndentParser

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> return true
      <|> string "False" *> return false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  return c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> return '\n')
         <|> (char 'r' *> return '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ fromList $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> return nm
    Just _  -> fail $ nm ++ " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = toList $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.fromChar) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String Expr
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String Expr
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> return (Binary op)) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String Expr
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          return $ \e -> case e of
            Atom (AInt ai) -> (Atom (AInt (-ai)))
            _              -> Unary Sub e

    infixOperator :: Operator m String Expr
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          return $ \e1 e2 -> Binary (InfixFunc n) e1 e2

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> return op)) <$> x) $ concat $ (\x -> toList <$> x) $ toList infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      return $ InfixFunc n

-- | Parse an expression between spaces (backtracks)
spaced :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
spaced p = PC.try $ PC.between skipSpaces skipSpaces p

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
applicationOrSingleExpression expr = do
  e <- (base expr)
  mArgs <- PC.optionMaybe (PC.try $ skipSpaces *> ((PC.try (base expr)) `PC.sepEndBy1` skipSpaces))
  case mArgs of
    Nothing   -> return e
    Just args -> return $ App e args

-- | Parse an if_then_else construct
ifThenElse :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
ifThenElse expr = do
  string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- spaced expr
  string "then"
  thenExpr <- spaced expr
  string "else"
  elseExpr <- spaced expr
  return $ IfExpr testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions.
tuplesOrBrackets :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
tuplesOrBrackets expr = do
  char '(' *> skipSpaces
  e <- expr
  skipSpaces
  mes <- PC.optionMaybe $ PC.try $ do
    char ',' *> skipSpaces
    expr `PC.sepBy1` (PC.try $ skipSpaces *> char ',' *> skipSpaces)
  skipSpaces
  char ')'
  case mes of
    Nothing -> return e
    Just es -> return $ NTuple (Cons e es)

-- | Parser for operator sections
section :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
section expr = do
  char '('
  skipSpaces
  me1 <- PC.optionMaybe (syntax expr)
  skipSpaces
  op <- opParser
  skipSpaces
  me2 <- PC.optionMaybe (syntax expr)
  skipSpaces
  char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> return $ PrefixOp op
        Just e2 -> return $ SectR op e2
    Just e1 ->
      case me2 of
        Nothing -> return $ SectL e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists
list :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
list expr = do
  char '['
  skipSpaces
  exprs <- expr `PC.sepBy` (PC.try $ skipSpaces *> char ',' *> skipSpaces)
  skipSpaces
  char ']'
  return $ List exprs

-- | Parser for Arithmetic Sequences
arithmeticSequence :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
arithmeticSequence expr = do
  char '['
  skipSpaces
  start <- expr
  skipSpaces
  step <- PC.optionMaybe $ (char ',') *> skipSpaces *> expr
  skipSpaces
  string ".."
  end <- PC.optionMaybe $ spaced expr
  skipSpaces
  char ']'
  return $ ArithmSeq start step end

-- | Parser for List Comprehensions
listComp :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
listComp expr = do
  char '['
  skipSpaces
  start <- expr
  skipSpaces
  PC.try $ char '|' <* PC.notFollowedBy (char '|')
  skipSpaces
  quals <- (qual expr) `PC.sepBy1` (PC.try $ skipSpaces *> char ',' *> skipSpaces)
  skipSpaces
  char ']'
  return $ ListComp start quals

qual :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m ExprQual
qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
  where
    parseLet = do
      string "let" *> skipSpaces
      b <- binding
      skipSpaces *> char '=' *> skipSpaces
      e <- expr
      return $ Let b e
    parseGen = do
      b <- binding
      skipSpaces *> string "<-" *> skipSpaces
      e <- expr
      return $ Gen b e
    parseGuard = do
      e <- expr
      return $ Guard e

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m Expr
charList = do
  char '"'
  strs <- many character'
  char '"'
  return (List ((Atom <<< Char <<< String.fromChar) <$> strs))

-- | Parse a lambda expression
lambda :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
lambda expr = do
  char '\\' *> skipSpaces
  binds <- (binding `PC.sepEndBy1` skipSpaces)
  string "->" *> skipSpaces
  body <- expr
  return $ Lambda binds body

-- | Parser for let expression
letExpr :: forall m. (Monad m) => ParserT String m Expr -> ParserT String m Expr
letExpr expr = do
  string "let" *> skipSpaces
  bnd <- binding
  skipSpaces *> char '=' *> skipSpaces
  lexp <- expr
  skipSpaces *> string "in" *> skipSpaces
  body <- expr
  return $ LetExpr bnd lexp body

-- | Parse an arbitrary expression
expression :: forall m. (Monad m) => ParserT String m Expr
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

parseExpr :: String -> Either ParseError Expr
parseExpr input = runParser input expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m Binding
lit = Lit <$> atom

consLit :: forall m. (Monad m) => ParserT String m Binding -> ParserT String m Binding
consLit bnd = do
  char '(' *> skipSpaces
  b <- consLit'
  skipSpaces *> char ')'
  return b
  where
    consLit' :: ParserT String m Binding
    consLit' = do
      b <- bnd
      skipSpaces *> char ':' *> skipSpaces
      bs <- PC.try consLit' <|> bnd
      return $ ConsLit b bs

listLit :: forall m. (Monad m) => ParserT String m Binding -> ParserT String m Binding
listLit bnd = do
  char '[' *> skipSpaces
  bs <- bnd `PC.sepBy` (PC.try $ skipSpaces *> char ',' *> skipSpaces)
  skipSpaces *> char ']'
  return $ ListLit bs

tupleLit :: forall m. (Monad m) => ParserT String m Binding -> ParserT String m Binding
tupleLit bnd = do
  char '(' *> skipSpaces
  b <- bnd
  skipSpaces *> char ',' *> skipSpaces
  bs <- bnd `PC.sepBy1` (PC.try $ skipSpaces *> char ',' *> skipSpaces)
  skipSpaces *> char ')'
  return $ NTupleLit (Cons b bs)

binding :: forall m. (Monad m) => ParserT String m Binding
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: forall m. (Monad m) => ParserT String m Definition
definition = do
  defName <- name
  skipSpaces
  binds <- binding `PC.sepEndBy` skipSpaces
  char '='
  skipSpaces
  body <- expression
  return $ Def defName binds body

definitions :: forall m. (Monad m) => ParserT String m (List Definition)
definitions = do
  whiteSpace
  definition `PC.sepEndBy` whiteSpace

parseDefs :: String -> Either ParseError (List Definition)
parseDefs input = runParser input definitions

----------------------------------------------------------------------
-- Multiline Parsing
----------------------------------------------------------------------

skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

testIndent :: forall a. (Show a) => IndentParser String a -> String -> String
testIndent p src = case fst $ flip runState initialPos $ runParserT (PState {input: src,position: initialPos}) p of
  Right r -> "parse success : " ++ show r
  Left  l -> "parse fail    : " ++ show l

data TestBlock = TestBlock Char (List Char)

instance showTest :: Show TestBlock where
  show (TestBlock c cs) = "TestBlock " ++ show c ++ " " ++ show cs

chara :: forall m. (Monad m) => ParserT String m Char
chara = do
  c <- anyLetter
  skipWhite
  return c

testBlockParser :: IndentParser String TestBlock
testBlockParser = withBlock TestBlock chara chara

module Parser where

import Prelude (Unit, bind, return, ($), (<$>), (<<<), unit, (++), void, id, flip, negate, liftM1)
import Data.String as String
import Data.List (List(Cons), many, toList, concat, elemIndex, fromList)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)

import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Control.Lazy (fix)
import Data.Identity (Identity)
import Data.Either (Either)

import Text.Parsing.Parser (ParseError, Parser, runParser, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (TokenParser, unGenLanguageDef, upper, digit, makeTokenParser)
import Text.Parsing.Parser.Language (haskellDef)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Qual(..), ExprQual, Op(..))

tokenParser :: TokenParser
tokenParser = makeTokenParser haskellDef

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Skip spaces and tabs
eatSpaces :: Parser String Unit
eatSpaces = void $ many $ oneOf [' ','\t']

anyDigit :: Parser String Char
anyDigit = digit

-- | Parser for Int. (0 to 2^31-1)
int :: Parser String Atom
int = AInt <$> tokenParser.decimal

-- | Parser for Boolean
bool :: Parser String Atom
bool = string "True"  *> return (Bool true)
   <|> string "False" *> return (Bool false)

-- | Parser for characters at the start of variables
lowerCaseLetter :: Parser String Char
lowerCaseLetter = oneOf $ String.toCharArray "_abcdefghijklmnopqrstuvwxyz"

-- | Parser for characters at the start of constructors and types
upperCaseLetter :: Parser String Char
upperCaseLetter = upper

-- | Parser for all characters after the first in names
anyLetter :: Parser String Char
anyLetter = lowerCaseLetter <|> upperCaseLetter <|> char '\'' <|> anyDigit

-- | List of reserved key words
reservedWords :: List String
reservedWords = toList $ (unGenLanguageDef haskellDef).reservedNames

character' :: Parser String Char
character' =
      (char '\\' *>
        (    (char 'n' *> return '\n')
         <|> (char 'r' *> return '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

character :: Parser String Atom
character = liftM1 (Char <<< String.fromChar) tokenParser.charLiteral

-- | Parser for variables names
name :: Parser String String
name = do
  c <- lowerCaseLetter
  cs <- many anyLetter
  let nm = String.fromCharArray $ fromList $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> return nm
    Just _  -> fail $ nm ++ " is a reserved word!"

-- | Parser for variable atoms
variable :: Parser String Atom
variable = Name <$> name

-- | Parser for atoms
atom :: Parser String Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Fail if the specified parser matches.
notFollowedBy :: forall a. Parser String a -> Parser String Unit
notFollowedBy p = PC.try $ (PC.try p *> fail "Negated parser succeeded") <|> return unit

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: Array (Array (Tuple3 (Parser String String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: OperatorTable Identity String Expr
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable Identity String Expr
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> return (Binary op)) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator Identity String Expr
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          return $ \e -> case e of
            Atom (AInt ai) -> (Atom (AInt (-ai)))
            _              -> Unary Sub e

    infixOperator :: Operator Identity String Expr
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          return $ \e1 e2 -> Binary (InfixFunc n) e1 e2

opParser :: Parser String Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> return op)) <$> x) $ concat $ (\x -> toList <$> x) $ toList infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      return $ InfixFunc n

-- | Parse an expression between brackets
brackets :: forall a. Parser String a -> Parser String a
brackets = tokenParser.parens

-- | Parse an expression between spaces (backtracks)
spaced :: forall a. Parser String a -> Parser String a
spaced p = PC.try $ PC.between eatSpaces eatSpaces p

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: Parser String Expr -> Parser String Expr
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: Parser String Expr -> Parser String Expr
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: Parser String Expr -> Parser String Expr
applicationOrSingleExpression expr = do
  e <- (base expr)
  mArgs <- PC.optionMaybe (PC.try $ eatSpaces *> ((PC.try (base expr)) `PC.sepEndBy1` eatSpaces))
  case mArgs of
    Nothing   -> return e
    Just args -> return $ App e args

-- | Parse an if_then_else construct
ifThenElse :: Parser String Expr -> Parser String Expr
ifThenElse expr = do
  string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- spaced expr
  string "then"
  thenExpr <- spaced expr
  string "else"
  elseExpr <- spaced expr
  return $ IfExpr testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions.
tuplesOrBrackets :: Parser String Expr -> Parser String Expr
tuplesOrBrackets expr = do
  char '(' *> eatSpaces
  e <- expr
  eatSpaces
  mes <- PC.optionMaybe $ PC.try $ do
    char ',' *> eatSpaces
    expr `PC.sepBy1` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces
  char ')'
  case mes of
    Nothing -> return e
    Just es -> return $ NTuple (Cons e es)

-- | Parser for operator sections
section :: Parser String Expr -> Parser String Expr
section expr = do
  char '('
  eatSpaces
  me1 <- PC.optionMaybe (syntax expr)
  eatSpaces
  op <- opParser
  eatSpaces
  me2 <- PC.optionMaybe (syntax expr)
  eatSpaces
  char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> return $ PrefixOp op
        Just e2 -> return $ SectR op e2
    Just e1 ->
      case me2 of
        Nothing -> return $ SectL e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists
list :: Parser String Expr -> Parser String Expr
list expr = do
  char '['
  eatSpaces
  exprs <- expr `PC.sepBy` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces
  char ']'
  return $ List exprs

-- | Parser for Arithmetic Sequences
arithmeticSequence :: Parser String Expr -> Parser String Expr
arithmeticSequence expr = do
  char '['
  eatSpaces
  start <- expr
  eatSpaces
  step <- PC.optionMaybe $ (char ',') *> eatSpaces *> expr
  eatSpaces
  string ".."
  end <- PC.optionMaybe $ spaced expr
  eatSpaces
  char ']'
  return $ ArithmSeq start step end

-- | Parser for List Comprehensions
listComp :: Parser String Expr -> Parser String Expr
listComp expr = do
  char '['
  eatSpaces
  start <- expr
  eatSpaces
  PC.try $ char '|' <* notFollowedBy (char '|')
  eatSpaces
  quals <- (qual expr) `PC.sepBy1` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces
  char ']'
  return $ ListComp start quals

qual :: Parser String Expr -> Parser String ExprQual
qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
  where
    parseLet = do
      string "let" *> eatSpaces
      b <- binding
      eatSpaces *> char '=' *> eatSpaces
      e <- expr
      return $ Let b e
    parseGen = do
      b <- binding
      eatSpaces *> string "<-" *> eatSpaces
      e <- expr
      return $ Gen b e
    parseGuard = do
      e <- expr
      return $ Guard e

-- | Parser for strings ("example")
charList :: Parser String Expr
charList = do
  char '"'
  strs <- many character'
  char '"'
  return (List ((Atom <<< Char <<< String.fromChar) <$> strs))

-- | Parse a lambda expression
lambda :: Parser String Expr -> Parser String Expr
lambda expr = do
  char '\\' *> eatSpaces
  binds <- (binding `PC.sepEndBy1` eatSpaces)
  string "->" *> eatSpaces
  body <- expr
  return $ Lambda binds body

-- | Parser for let expression
letExpr :: Parser String Expr -> Parser String Expr
letExpr expr = do
  string "let" *> eatSpaces
  bnd <- binding
  eatSpaces *> char '=' *> eatSpaces
  lexp <- expr
  eatSpaces *> string "in" *> eatSpaces
  body <- expr
  return $ LetExpr bnd lexp body

-- | Parse an arbitrary expression
expression :: Parser String Expr
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

parseExpr :: String -> Either ParseError Expr
parseExpr input = runParser input expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

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

consLit :: Parser String Binding -> Parser String Binding
consLit bnd = do
  char '(' *> eatSpaces
  b <- consLit'
  eatSpaces *> char ')'
  return b
  where
    consLit' :: Parser String Binding
    consLit' = do
      b <- bnd
      eatSpaces *> char ':' *> eatSpaces
      bs <- PC.try consLit' <|> bnd
      return $ ConsLit b bs

listLit :: Parser String Binding -> Parser String Binding
listLit bnd = do
  char '[' *> eatSpaces
  bs <- bnd `PC.sepBy` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces *> char ']'
  return $ ListLit bs

tupleLit :: Parser String Binding -> Parser String Binding
tupleLit bnd = do
  char '(' *> eatSpaces
  b <- bnd
  eatSpaces *> char ',' *> eatSpaces
  bs <- bnd `PC.sepBy1` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces *> char ')'
  return $ NTupleLit (Cons b bs)

binding :: Parser String Binding
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: Parser String Definition
definition = do
  defName <- name
  eatSpaces
  binds <- binding `PC.sepEndBy` eatSpaces
  char '='
  eatSpaces
  body <- expression
  return $ Def defName binds body

definitions :: Parser String (List Definition)
definitions = do
  whiteSpace
  definition `PC.sepEndBy` whiteSpace

parseDefs :: String -> Either ParseError (List Definition)
parseDefs input = runParser input definitions


Add operator sections to the parser

Add operator sections to the parser

module Parser where

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

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

import AST

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

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

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

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

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

list :: Parser String Expr -> Parser String Expr
list expr = do
  string "["
  eatSpaces
  ls <- expr `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return $ List ls

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

bracket :: Parser String Expr -> Parser String Expr
bracket expr = do
  string "("
  eatSpaces
  e <- expr
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = do
  mop1 <- optionMaybe $ choice ops
  eatSpaces
  e <- optionMaybe $ base expr
  eatSpaces
  mop2 <- optionMaybe $ choice ops
  match mop1 e mop2
  where
  match (Just op) (Just e)  (Nothing) = return $ SectR op e
  match (Nothing) (Just e)  (Just op) = return $ SectL e op
  match (Nothing) (Just e)  (Nothing) = return e
  match (Just op) (Nothing) (Nothing) = return $ (App (show op) [])
  match _         _         _         = fail "Neither section nor expression!"
  ops =
    [ op (string "+" *> notFollowedBy (string "+")) Add
    , op (string "-" *> notFollowedBy num) Sub
    , op (string "*")     Mul
    , op (string "`div`") Div
    , op (string ":")     Cons
    , op (string "++")    Append
    , op (string "&&")    And
    , op (string "||")    Or
    ]

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

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

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

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

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

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

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

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

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

module Parser where

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

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

import AST

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

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

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

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

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

list :: Parser String Expr -> Parser String Expr
list expr = do
  string "["
  eatSpaces
  ls <- expr `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return $ List ls

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

bracket :: Parser String Expr -> Parser String Expr
bracket expr = do
  string "("
  eatSpaces
  e <- expr
  eatSpaces
  string ")"
  return e

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

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

op :: forall a. Parser String a -> Op -> Parser String (Expr -> Expr -> Expr)
op opParser opType = try $
  (eatSpaces *> opParser *> eatSpaces) *> return (Binary opType)

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

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

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

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term5r expr) (op (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (op (string "||") Or)

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


Start working on using Int indices for Vectors

Using a lot of voodoo right now, since the types do not quite work out.
In fact, I do believe there is no valid explicit type signature for
updateAtI and deleteAtI (the inner type variable and its constraint
cannot be represented outside of the compiler).

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

mapWithIndex :: forall s a b. (Nat s) => (Int -> a -> b) -> Vec s a -> Vec s b
mapWithIndex mapper (Vec array) = Vec (Array.mapWithIndex mapper array)

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

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

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

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

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

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


tests for combined battle (proceeding to night)

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.FFI
import Test.Unit.Assert as Assert
import Data.Foldable

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

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)

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]
  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
    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.FFI
import Test.Unit.Assert as Assert
import Data.Foldable

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

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)

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]
  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
    trimInfo :: forall a. Array (Maybe { hp :: Int | a}) -> Array (Maybe Int)
    trimInfo = (map <<< map) (\x -> x.hp)


Removed rendundant function

Removed rendundant function

{-
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.Card.Next.NextAction where

import SlamData.Prelude

import Data.Array as A

import SlamData.Workspace.Card.InsertableCardType (InsertableCardType)
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType (allChartTypes)
import SlamData.Workspace.Card.Port (Port)
import SlamData.ActionList.Component as ActionList

data NextAction
  = Insert CardType
  | FindOutHowToInsert CardType

chartSubmenu ∷ ActionList.Action NextAction
chartSubmenu =
  ActionList.Drill
    (ActionList.ActionName "Setup Chart")
    (ActionList.ActionIconSrc "img/cardsLight/setupChart.svg")
    (ActionList.ActionDescription "Select Setup Chart card category")
    (map (toAction ∘ Insert ∘ CT.ChartOptions) allChartTypes)

findOutHowToChartSubmenu ∷ ActionList.Action NextAction
findOutHowToChartSubmenu =
  ActionList.Drill
    (ActionList.ActionName "Setup Chart")
    (ActionList.ActionIconSrc "img/cardsLight/setupChart.svg")
    (ActionList.ActionDescription "Select Setup Chart card category")
    (map (toAction ∘ FindOutHowToInsert ∘ CT.ChartOptions) allChartTypes)

toAction ∷ NextAction → ActionList.Action NextAction
toAction =
  case _ of
    nextAction@(Insert cardType) →
      ActionList.Do
        (name cardType)
        (ActionList.ActionIconSrc $ CT.cardIconLightSrc cardType)
        (description nextAction)
        (ActionList.ActionHighlighted true)
        nextAction
    nextAction@(FindOutHowToInsert cardType) →
      ActionList.Do
        (name cardType)
        (ActionList.ActionIconSrc $ CT.cardIconLightSrc cardType)
        (description nextAction)
        (ActionList.ActionHighlighted false)
        nextAction

name ∷ CardType → ActionList.ActionName
name =
  ActionList.ActionName ∘ CT.cardName

description ∷ NextAction → ActionList.ActionDescription
description =
  ActionList.ActionDescription ∘ case _ of
    Insert cty → "Insert a " ⊕ CT.cardName cty ⊕ " card"
    FindOutHowToInsert cty → "Find out how to insert a " ⊕ CT.cardName cty ⊕ " card"

instance eqNextAction ∷ Eq NextAction where
  eq (Insert cty1) (Insert cty2) = cty1 ≡ cty2
  eq (FindOutHowToInsert cty1) (FindOutHowToInsert cty2) = cty1 ≡ cty2
  eq _ _ = false

insert ∷ InsertableCardType → ActionList.Action NextAction
insert =
  case _ of
    ICT.SetupChartCard → chartSubmenu
    iCardType → toAction $ Insert $ ICT.toCardType iCardType

findOutHowToInsert ∷ InsertableCardType → ActionList.Action NextAction
findOutHowToInsert =
  case _ of
    ICT.SetupChartCard → findOutHowToChartSubmenu
    iCardType → toAction $ FindOutHowToInsert $ ICT.toCardType iCardType

fromInsertableCard ∷ InsertableCardType → Array InsertableCardType → ActionList.Action NextAction
fromInsertableCard x =
  maybe (findOutHowToInsert x) (const $ insert x) ∘ A.findIndex (eq x)

fromPort ∷ Port → Array (ActionList.Action NextAction)
fromPort port =
  flip fromInsertableCard (ICT.cardsThatTakeInput $ ICT.fromPort port) <$> ICT.all

fromMaybePort ∷ Maybe Port → Array (ActionList.Action NextAction)
fromMaybePort = maybe (flip fromInsertableCard (ICT.cardsThatTakeInput ICT.None) <$> ICT.all) fromPort

isInsert ∷ NextAction → Boolean
isInsert (Insert _) = true
isInsert _ = false

{-
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.Card.Next.NextAction where

import SlamData.Prelude

import Data.Array as A

import SlamData.Workspace.Card.InsertableCardType (InsertableCardType)
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType (allChartTypes)
import SlamData.Workspace.Card.Port (Port)
import SlamData.ActionList.Component as ActionList

data NextAction
  = Insert CardType
  | FindOutHowToInsert CardType

chartSubmenu ∷ ActionList.Action NextAction
chartSubmenu =
  ActionList.Drill
    (ActionList.ActionName "Setup Chart")
    (ActionList.ActionIconSrc "img/cardsLight/setupChart.svg")
    (ActionList.ActionDescription "Select Setup Chart card category")
    (map (toAction ∘ Insert ∘ CT.ChartOptions) allChartTypes)

findOutHowToChartSubmenu ∷ ActionList.Action NextAction
findOutHowToChartSubmenu =
  ActionList.Drill
    (ActionList.ActionName "Setup Chart")
    (ActionList.ActionIconSrc "img/cardsLight/setupChart.svg")
    (ActionList.ActionDescription "Select Setup Chart card category")
    (map (toAction ∘ FindOutHowToInsert ∘ CT.ChartOptions) allChartTypes)

toAction ∷ NextAction → ActionList.Action NextAction
toAction =
  case _ of
    nextAction@(Insert cardType) →
      ActionList.Do
        (name cardType)
        (ActionList.ActionIconSrc $ CT.cardIconLightSrc cardType)
        (description nextAction)
        (ActionList.ActionHighlighted true)
        nextAction
    nextAction@(FindOutHowToInsert cardType) →
      ActionList.Do
        (name cardType)
        (ActionList.ActionIconSrc $ CT.cardIconLightSrc cardType)
        (description nextAction)
        (ActionList.ActionHighlighted false)
        nextAction

name ∷ CardType → ActionList.ActionName
name =
  ActionList.ActionName ∘ CT.cardName

description ∷ NextAction → ActionList.ActionDescription
description =
  ActionList.ActionDescription ∘ case _ of
    Insert cty → "Insert a " ⊕ CT.cardName cty ⊕ " card"
    FindOutHowToInsert cty → "Find out how to insert a " ⊕ CT.cardName cty ⊕ " card"

instance eqNextAction ∷ Eq NextAction where
  eq (Insert cty1) (Insert cty2) = cty1 ≡ cty2
  eq (FindOutHowToInsert cty1) (FindOutHowToInsert cty2) = cty1 ≡ cty2
  eq _ _ = false

foldToArray ∷ NextAction → Array CardType
foldToArray = case _ of
  Insert cty → [ cty ]
  FindOutHowToInsert cty → [ cty ]

insert ∷ InsertableCardType → ActionList.Action NextAction
insert =
  case _ of
    ICT.SetupChartCard → chartSubmenu
    iCardType → toAction $ Insert $ ICT.toCardType iCardType

findOutHowToInsert ∷ InsertableCardType → ActionList.Action NextAction
findOutHowToInsert =
  case _ of
    ICT.SetupChartCard → findOutHowToChartSubmenu
    iCardType → toAction $ FindOutHowToInsert $ ICT.toCardType iCardType

fromInsertableCard ∷ InsertableCardType → Array InsertableCardType → ActionList.Action NextAction
fromInsertableCard x =
  maybe (findOutHowToInsert x) (const $ insert x) ∘ A.findIndex (eq x)

fromPort ∷ Port → Array (ActionList.Action NextAction)
fromPort port =
  flip fromInsertableCard (ICT.cardsThatTakeInput $ ICT.fromPort port) <$> ICT.all

fromMaybePort ∷ Maybe Port → Array (ActionList.Action NextAction)
fromMaybePort = maybe (flip fromInsertableCard (ICT.cardsThatTakeInput ICT.None) <$> ICT.all) fromPort

isInsert ∷ NextAction → Boolean
isInsert (Insert _) = true
isInsert _ = false