renamed, removed unused import

renamed, removed unused import

{-
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.Quasar.FS
  ( children
  , transitiveChildren
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (error)

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.List as List
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

import Quasar.Advanced.QuasarAF as QF
import Quasar.Error (QError(..))
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)
import SlamData.Quasar.Data as QD

import SlamData.Workspace.Model as WM
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Card.Draftboard.Pane as Pane

import Utils.Array (enumerate)
import Utils.Ace (RangeRec)

children
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go :: R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let
    srcPath = R.getPath src

  runExceptT ∘ traverse cleanViewMounts $ srcPath ^? _Left

  runExceptT case src of
    R.Workspace wsDir → replacePathsInWorkspace wsDir
    _ → pure unit

  result ←
    case src of
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt

  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err

  where
  replacePathsInWorkspace ∷ DirPath → ExceptT QError m Unit
  replacePathsInWorkspace wsDir = do
    mbDid ← getWorkspaceRoot wsDir
    for_ mbDid \did → do
      deck ← getDeck wsDir did
      (save × newDeck) ← replacePathsInDeck wsDir deck
      when save $ putDeck wsDir did newDeck

  getWorkspaceRoot ∷ DirPath → ExceptT QError m (Maybe DID.DeckId)
  getWorkspaceRoot wsDir = do
    wmJS ← ExceptT $ QD.load $ wsDir </> P.file "index"
    deck ← ExceptT $ pure $ lmap (Error ∘ error) $ WM.decode wmJS
    pure deck.root

  getDeck ∷ DirPath → DID.DeckId → ExceptT QError m DM.Deck
  getDeck wsDir did = do
    deckJS ← ExceptT $ QD.load $ wsDir </> P.dir (DID.deckIdToString did) </> P.file "index"
    ExceptT $ pure $ lmap (Error ∘ error) $ DM.decode deckJS

  putDeck ∷ DirPath → DID.DeckId → DM.Deck → ExceptT QError m Unit
  putDeck wsDir did deck =
    ExceptT
      $ QD.save
        (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
        (DM.encode deck)

  replacePathsInDeck ∷ DirPath → DM.Deck → ExceptT QError m (Boolean × DM.Deck)
  replacePathsInDeck wsDir deck =
    let
      replaceCardModel ∷ CM.Model → DM.Deck → DM.Deck
      replaceCardModel card@{cardId} d =
        d { cards =
               Arr.sortBy (\{cardId: a} {cardId: b} → compare a b)
               $ Arr.cons card
               $ Arr.filter (not ∘ eq cardId ∘ _.cardId) d.cards
          }

      foldFn ∷ Boolean × DM.Deck → CM.Model → ExceptT QError m (Boolean × DM.Deck)
      foldFn current@(shouldSave × d) {cardId, model} = case model of
        CM.Draftboard m → do
          flip parTraverse_ (List.catMaybes $ Pane.toList m.layout) \did → do
            d' ← getDeck wsDir  did
            (save × newDeck) ← replacePathsInDeck wsDir d'
            when save $ putDeck wsDir did newDeck
          pure current
        CM.Cache m →
          let
            newM =
              S.replace
                (S.Pattern $ P.printPath wsDir)
                (S.Replacement $ either P.printPath P.printPath tgt)
                <$> m
            newCard = {cardId, model: CM.Cache newM}
          in
            pure $ true × replaceCardModel newCard d
        CM.Open mbR →
          let
            newMbR = do
              r ← mbR
              rel ←
                bisequence
                  $ bimap (flip P.relativeTo wsDir) (flip P.relativeTo wsDir)
                  $ R.getPath r
              tgtDir ← either Just (const Nothing) tgt
              let
                newP =
                  bimap P.canonicalize P.canonicalize
                  $ bimap (tgtDir </> _) (tgtDir </> _) rel
              pure $ R.setPath r newP

            newCard = {cardId, model: CM.Open newMbR}
          in
            pure $ (newMbR ≠ mbR) × replaceCardModel newCard d
        CM.Ace mode (Just m) →
          let
            wsStr ∷ String
            wsStr = P.printPath wsDir

            pat ∷ S.Pattern
            pat = S.Pattern wsStr

            tgtStr ∷ String
            tgtStr = either P.printPath P.printPath tgt

            replacement ∷ S.Replacement
            replacement = S.Replacement tgtStr

            srcLen ∷ Int
            srcLen = S.length wsStr

            tgtLen ∷ Int
            tgtLen = S.length tgtStr

            lenDiff ∷ Int
            lenDiff = tgtLen - srcLen

            sortRangeRecs ∷ Array RangeRec → Array RangeRec
            sortRangeRecs =
              Arr.sortBy \a b →
                compare a.startRow b.startRow
                ⊕ compare a.startColumn b.startColumn

            -- We don't care about endings
            eqRangeRec ∷ RangeRec → RangeRec → Boolean
            eqRangeRec a b =
              -- That's a bug workaround, modification of ace field for whatever reason
              -- removes one space left padding :(
              (a.startColumn ≡ b.startColumn
               ∨ a.startColumn + one ≡ b.startColumn
               ∨ a.startColumn - one ≡ b.startColumn)
              ∧ a.startRow ≡ b.startRow

            substrIndices
              ∷ S.Pattern
              → Array (Int × String)
              → Array RangeRec
            substrIndices needle =
              sortRangeRecs ∘ foldl foldRanges [ ]
              where
              findStartColumns ∷ Array Int → String → Array Int
              findStartColumns accum hay =
                case S.indexOf needle hay of
                  Nothing → accum
                  Just i → findStartColumns (Arr.cons i accum) $ S.drop (i + srcLen) hay

              foldRanges
                ∷ Array RangeRec
                → Int × String
                → Array RangeRec
              foldRanges accum (startRow × hay) =
                let
                  starts = findStartColumns [] hay
                  fromKWlen = 6
                  mkRange start =
                    [ { startColumn: start - fromKWlen
                      , endColumn: 0
                      , startRow
                      , endRow: startRow
                      } ]
                in
                 foldMap mkRange starts ⊕ accum

            initialRanges ∷ Array RangeRec
            initialRanges = substrIndices pat $ enumerate $ S.split (S.Pattern "\n") m.text

            -- inputs must be sorted
            filterRanges
              ∷ Array RangeRec
              → Array RangeRec
              → Array RangeRec
              → Array RangeRec
            filterRanges accum needles hays = fromMaybe accum do
              needles' ← Arr.uncons needles
              hays' ← Arr.uncons hays
              pure
                $ if eqRangeRec hays'.head needles'.head
                -- Note that we use stuff from hays, because it has endColumn and endRow
                  then
                    filterRanges
                      (Arr.snoc
                         accum
                         hays'.head{ endColumn = hays'.head.endColumn
                                                 + lenDiff
                                                 + hays'.head.startRow
                                                 - one
                                   , startColumn = hays'.head.startColumn
                                                   - hays'.head.startRow
                                                   - one
                                   })
                      needles'.tail
                      hays
                  else
                    filterRanges
                      (Arr.snoc accum hays'.head)
                      needles
                      hays'.tail

            newText ∷ String
            newText = S.replace pat replacement m.text

            newRanges ∷ Array RangeRec
            newRanges
              | newText ≠ m.text  =
                filterRanges [ ] initialRanges $ sortRangeRecs m.ranges
              | otherwise = m.ranges

            newCard = {cardId, model: CM.Ace mode (Just {text: newText, ranges: newRanges})}
          in
            pure $ (newText ≠ m.text) × replaceCardModel newCard d

        _ → pure current
    in
      Arr.foldM foldFn (false × deck) deck.cards

delete
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . (QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → String
  → m (Either QError (Maybe String))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ a. Either QF.QError a → Either QError (Maybe String)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)

{-
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.Quasar.FS
  ( children
  , transitiveChildren
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (error)

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.List as List
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

--import Math as Math

import Quasar.Advanced.QuasarAF as QF
import Quasar.Error (QError(..))
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)
import SlamData.Quasar.Data as QD

import SlamData.Workspace.Model as WM
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Card.Draftboard.Pane as Pane

import Utils.Array (enumerate)
import Utils.Ace (RangeRec)

children
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go :: R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let
    srcPath = R.getPath src

  runExceptT ∘ traverse cleanViewMounts $ srcPath ^? _Left

  runExceptT case src of
    R.Workspace wsDir → replacePathsInDecks wsDir
    _ → pure unit

  result ←
    case src of
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt

  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err

  where
  replacePathsInDecks ∷ DirPath → ExceptT QError m Unit
  replacePathsInDecks wsDir = do
    mbDid ← getWorkspaceRoot wsDir
    for_ mbDid \did → do
      deck ← getDeck wsDir did
      (save × newDeck) ← oneDeck wsDir deck
      when save $ putDeck wsDir did newDeck

  getWorkspaceRoot ∷ DirPath → ExceptT QError m (Maybe DID.DeckId)
  getWorkspaceRoot wsDir = do
    wmJS ← ExceptT $ QD.load $ wsDir </> P.file "index"
    deck ← ExceptT $ pure $ lmap (Error ∘ error) $ WM.decode wmJS
    pure deck.root

  getDeck ∷ DirPath → DID.DeckId → ExceptT QError m DM.Deck
  getDeck wsDir did = do
    deckJS ← ExceptT $ QD.load $ wsDir </> P.dir (DID.deckIdToString did) </> P.file "index"
    ExceptT $ pure $ lmap (Error ∘ error) $ DM.decode deckJS

  putDeck ∷ DirPath → DID.DeckId → DM.Deck → ExceptT QError m Unit
  putDeck wsDir did deck =
    ExceptT
      $ QD.save
        (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
        (DM.encode deck)

  oneDeck ∷ DirPath → DM.Deck → ExceptT QError m (Boolean × DM.Deck)
  oneDeck wsDir deck =
    let
      replaceCardModel ∷ CM.Model → DM.Deck → DM.Deck
      replaceCardModel card@{cardId} d =
        d { cards =
               Arr.sortBy (\{cardId: a} {cardId: b} → compare a b)
               $ Arr.cons card
               $ Arr.filter (not ∘ eq cardId ∘ _.cardId) d.cards
          }

      foldFn ∷ Boolean × DM.Deck → CM.Model → ExceptT QError m (Boolean × DM.Deck)
      foldFn current@(shouldSave × d) {cardId, model} = case model of
        CM.Draftboard m → do
          flip parTraverse_ (List.catMaybes $ Pane.toList m.layout) \did → do
            d' ← getDeck wsDir  did
            (save × newDeck) ← oneDeck wsDir d'
            when save $ putDeck wsDir did newDeck
          pure current
        CM.Cache m →
          let
            newM =
              S.replace
                (S.Pattern $ P.printPath wsDir)
                (S.Replacement $ either P.printPath P.printPath tgt)
                <$> m
            newCard = {cardId, model: CM.Cache newM}
          in
            pure $ true × replaceCardModel newCard d
        CM.Open mbR →
          let
            newMbR = do
              r ← mbR
              rel ←
                bisequence
                  $ bimap (flip P.relativeTo wsDir) (flip P.relativeTo wsDir)
                  $ R.getPath r
              tgtDir ← either Just (const Nothing) tgt
              let
                newP =
                  bimap P.canonicalize P.canonicalize
                  $ bimap (tgtDir </> _) (tgtDir </> _) rel
              pure $ R.setPath r newP

            newCard = {cardId, model: CM.Open newMbR}
          in
            pure $ (newMbR ≠ mbR) × replaceCardModel newCard d
        CM.Ace mode (Just m) →
          let
            wsStr ∷ String
            wsStr = P.printPath wsDir

            pat ∷ S.Pattern
            pat = S.Pattern wsStr

            tgtStr ∷ String
            tgtStr = either P.printPath P.printPath tgt

            replacement ∷ S.Replacement
            replacement = S.Replacement tgtStr

            srcLen ∷ Int
            srcLen = S.length wsStr

            tgtLen ∷ Int
            tgtLen = S.length tgtStr

            lenDiff ∷ Int
            lenDiff = tgtLen - srcLen

            sortRangeRecs ∷ Array RangeRec → Array RangeRec
            sortRangeRecs =
              Arr.sortBy \a b →
                compare a.startRow b.startRow
                ⊕ compare a.startColumn b.startColumn

            -- We don't care about endings
            eqRangeRec ∷ RangeRec → RangeRec → Boolean
            eqRangeRec a b =
              -- That's a bug workaround, modification of ace field for whatever reason
              -- removes one space left padding :(
              (a.startColumn ≡ b.startColumn
               ∨ a.startColumn + one ≡ b.startColumn
               ∨ a.startColumn - one ≡ b.startColumn)
              ∧ a.startRow ≡ b.startRow

            substrIndices
              ∷ S.Pattern
              → Array (Int × String)
              → Array RangeRec
            substrIndices needle =
              sortRangeRecs ∘ foldl foldRanges [ ]
              where
              findStartColumns ∷ Array Int → String → Array Int
              findStartColumns accum hay =
                case S.indexOf needle hay of
                  Nothing → accum
                  Just i → findStartColumns (Arr.cons i accum) $ S.drop (i + srcLen) hay

              foldRanges
                ∷ Array RangeRec
                → Int × String
                → Array RangeRec
              foldRanges accum (startRow × hay) =
                let
                  starts = findStartColumns [] hay
                  fromKWlen = 6
                  mkRange start =
                    [ { startColumn: start - fromKWlen
                      , endColumn: 0
                      , startRow
                      , endRow: startRow
                      } ]
                in
                 foldMap mkRange starts ⊕ accum

            initialRanges ∷ Array RangeRec
            initialRanges = substrIndices pat $ enumerate $ S.split (S.Pattern "\n") m.text

            -- inputs must be sorted
            filterRanges
              ∷ Array RangeRec
              → Array RangeRec
              → Array RangeRec
              → Array RangeRec
            filterRanges accum needles hays = fromMaybe accum do
              needles' ← Arr.uncons needles
              hays' ← Arr.uncons hays
              pure
                $ if eqRangeRec hays'.head needles'.head
                -- Note that we use stuff from hays, because it has endColumn and endRow
                  then
                    filterRanges
                      (Arr.snoc
                         accum
                         hays'.head{ endColumn = hays'.head.endColumn
                                                 + lenDiff
                                                 + hays'.head.startRow
                                                 - one
                                   , startColumn = hays'.head.startColumn
                                                   - hays'.head.startRow
                                                   - one
                                   })
                      needles'.tail
                      hays
                  else
                    filterRanges
                      (Arr.snoc accum hays'.head)
                      needles
                      hays'.tail

            newText ∷ String
            newText = S.replace pat replacement m.text

            newRanges ∷ Array RangeRec
            newRanges
              | newText ≠ m.text  =
                filterRanges [ ] initialRanges $ sortRangeRecs m.ranges
              | otherwise = m.ranges

            newCard = {cardId, model: CM.Ace mode (Just {text: newText, ranges: newRanges})}
          in
            pure $ (newText ≠ m.text) × replaceCardModel newCard d

        _ → pure current
    in
      Arr.foldM foldFn (false × deck) deck.cards

delete
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . (QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → String
  → m (Either QError (Maybe String))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ a. Either QF.QError a → Either QError (Maybe String)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)


Ensure module-loading format follows purescript convention (#11)

module HTTPure
  ( module HTTPure.HTTPureM
  , module HTTPure.Server
  , module HTTPure.Request
  , module HTTPure.Response
  , module HTTPure.Route
  ) where

import HTTPure.HTTPureM (HTTPureM)
import HTTPure.Server (serve)
import HTTPure.Request (Request, getURL)
import HTTPure.Response (Response, write)
import HTTPure.Route (Method(..), Route)

module HTTPure (
  module HTTPure.HTTPureM,
  module HTTPure.Server,
  module HTTPure.Request,
  module HTTPure.Response,
  module HTTPure.Route
) where

import HTTPure.HTTPureM (HTTPureM)
import HTTPure.Server (serve)
import HTTPure.Request (Request, getURL)
import HTTPure.Response (Response, write)
import HTTPure.Route (Method(..), Route)


Topological sort

Topological sort

Original commit a2b39b9d6f61aecac2e93cfaa0cb1f3bcb71c034

module Doc
    ( Doc
    , Renderer
    , Transforms
    , Namer
    , getTopLevels
    , getSingleTopLevel
    , getModuleName
    , getForSingleOrMultipleTopLevels
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , getTopLevelNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , lookupTopLevelName
    , forEachTopLevel_
    , forEachClass_
    , forEachUnion_
    , combineNames
    , NamingResult
    , transformNames
    , transformPropertyNames
    , simpleNamer
    , noForbidNamer
    , forbidNamer
    , unionNameIntercalated
    , unionIsNotSimpleNullable
    , getTopLevelPlural
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    , renderRenderItems
    ) where

import IR
import IRGraph
import Prelude

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Array as A
import Data.Foldable (for_, any, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, maybe, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.Sequence (Seq)
import Data.Sequence as Sq
import Data.String as String
import Data.String.Util (times) as String
import Data.Tuple (Tuple(..), fst, snd)
import Utils (forEnumerated_, sortByKeyM, mapM)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type NamingResult = { name :: String, forbid :: Array String }
type Namer a = a -> Maybe String -> NamingResult

type Transforms =
    { nameForClass :: Namer IRClassData
    , nextName :: String -> String
    , forbiddenNames :: Array String
    , topLevelName :: Namer String
    , unions :: Maybe
        { predicate :: IRUnionRep -> Boolean
        , properName :: Namer (Named (Set String))
        , nameFromTypes :: Namer (Array String)
        }
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map IRUnionRep String
    , topLevelNames :: Map String String
    , unionSet :: Set IRUnionRep
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph@(IRGraph { toplevels }) =
    let topLevelTuples = map (\n -> Tuple n n) $ M.keys toplevels
        forbiddenFromStart = S.fromFoldable t.forbiddenNames
        { names: topLevelNames, forbidden: forbiddenAfterTopLevels } = transformNames t.topLevelName t.nextName forbiddenFromStart topLevelTuples
        classes = classesInGraph graph
        { names: classNames, forbidden: forbiddenAfterClasses } = transformNames t.nameForClass t.nextName forbiddenAfterTopLevels classes
        { unionSet, unionNames } = doUnions classNames forbiddenAfterClasses
    in
        evalRWS w { graph, classNames, unionNames, topLevelNames, unionSet } { indent: 0 } # snd
    where
        doUnions :: Map Int String -> Set String -> { unionSet :: Set IRUnionRep, unionNames :: Map IRUnionRep String }
        doUnions classNames forbidden = case t.unions of
            Nothing -> { unionSet: S.empty, unionNames: M.empty }
            Just { predicate, properName, nameFromTypes } ->
                let unionSet = filterTypes (unionPredicate predicate) graph
                    unionNames = (transformNames (unionNamer nameFromTypes properName classNames) t.nextName forbidden $ map (\s -> Tuple s s) $ L.fromFoldable unionSet).names
                in
                    { unionSet, unionNames }

        unionPredicate :: (IRUnionRep -> Boolean) -> IRType -> Maybe IRUnionRep
        unionPredicate p (IRUnion ur) = if p ur then Just ur else Nothing
        unionPredicate _ _ = Nothing

        unionNamer :: Namer (Array String) -> Namer (Named (Set String)) -> Map Int String -> Namer IRUnionRep
        unionNamer nameFromTypes properName classNames union@(IRUnionRep { names }) =
            if namedValue names == S.empty then
                let typeStrings = map (typeNameForUnion graph classNames) $ A.sort $ A.fromFoldable $ unionToSet union
                in
                    nameFromTypes typeStrings
            else
                properName names

transformNames :: forall a b. Ord a => Ord b => Namer b -> (String -> String) -> Set String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
transformNames legalize otherize illegalNames names =
    process S.empty illegalNames M.empty names
    where
        makeName :: b -> NamingResult -> Set String -> Set String -> NamingResult
        makeName name result@{ name: tryName, forbid } forbiddenInScope forbiddenForAll =
            if S.member tryName forbiddenInScope || any (\x -> S.member x forbiddenForAll) forbid then
                makeName name (legalize name (Just $ otherize tryName)) forbiddenInScope forbiddenForAll
            else
                result
        process :: Set String -> Set String -> Map a String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
        process forbiddenInScope forbiddenForAll mapSoFar l =
            case l of
            L.Nil -> { names: mapSoFar, forbidden: forbiddenForAll }
            (Tuple identifier inputs) : rest ->
                let { name, forbid } = makeName inputs (legalize inputs Nothing) forbiddenInScope forbiddenForAll
                    newForbiddenInScope = S.insert name forbiddenInScope
                    newForbiddenForAll = S.union (S.fromFoldable forbid) forbiddenForAll
                    newMap = M.insert identifier name mapSoFar
                in
                    process newForbiddenInScope newForbiddenForAll newMap rest

transformPropertyNames :: Namer String -> (String -> String) -> Array String -> Map String IRType -> Map String String
transformPropertyNames legalize otherize illegalNamesArray properties =
    let illegalNames = S.fromFoldable illegalNamesArray
    in
        _.names $ transformNames legalize otherize illegalNames $ map (\n -> Tuple n n) $ M.keys properties

forbidNamer :: forall a. Ord a => (a -> String) -> (String -> Array String) -> Namer a
forbidNamer namer forbidder _ (Just name) = { name, forbid: forbidder name }
forbidNamer namer forbidder x Nothing =
    let name = namer x
    in { name, forbid: forbidder name }

simpleNamer :: forall a. Ord a => (a -> String) -> Namer a
simpleNamer namer = forbidNamer namer A.singleton

noForbidNamer :: forall a. Ord a => (a -> String) -> Namer a
noForbidNamer namer = forbidNamer namer (const [])

typeNameForUnion :: IRGraph -> Map Int String -> IRType -> String
typeNameForUnion graph classNames = case _ of
    IRNothing -> "anything"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph classNames a <> "_array"
    IRClass i -> lookupName i classNames
    IRMap t -> typeNameForUnion graph classNames t <> "_map"
    IRUnion _ -> "union"

unionNameIntercalated :: (String -> String) -> String -> Array String -> String
unionNameIntercalated nameStyle orString names =
    names
    <#> nameStyle
    # intercalate orString

unionIsNotSimpleNullable :: IRUnionRep -> Boolean
unionIsNotSimpleNullable ur = isNothing $ nullableFromSet $ unionToSet ur

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  classNames <- getClassNames
  pure $ typeNameForUnion g classNames typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevels :: Doc (Map String IRType)
getTopLevels = do
    IRGraph { toplevels } <- getGraph
    pure toplevels

getSingleTopLevel :: Doc (Maybe (Tuple String IRType))
getSingleTopLevel = do
    topLevels <- getTopLevels
    case M.toUnfoldable topLevels :: List _ of
        t : L.Nil -> pure $ Just t
        _ -> pure Nothing

getModuleName :: (String -> String) -> Doc String
getModuleName nameStyler = do
    single <- getSingleTopLevel
    pure $ maybe "QuickType" (fst >>> nameStyler) single

getForSingleOrMultipleTopLevels :: forall a. a -> a -> Doc a
getForSingleOrMultipleTopLevels forSingle forMultiple = do
    single <- getSingleTopLevel
    pure $ maybe forMultiple (const forSingle) single

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List IRUnionRep)
getUnions = do
    unsorted <- M.keys <$> getUnionNames
    sortByKeyM lookupUnionName unsorted

getUnionNames :: Doc (Map IRUnionRep String)
getUnionNames = Doc (asks _.unionNames)

getUnionSet :: Doc (Set IRUnionRep)
getUnionSet = Doc (asks _.unionSet)

getTopLevelNames :: Doc (Map String String)
getTopLevelNames = Doc (asks _.topLevelNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = do
    unsorted <- classesInGraph <$> getGraph
    sortByKeyM (\t -> lookupClassName (fst t)) unsorted

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: IRUnionRep -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

lookupTopLevelName :: String -> Doc String
lookupTopLevelName n = do
    topLevelNames <- getTopLevelNames
    pure $ lookupName n topLevelNames

type TopLevelIterator = String -> IRType -> Doc Unit
type ClassIterator = String -> Map String IRType -> Doc Unit
type UnionIterator = String -> Set IRType -> Doc Unit

callTopLevelIterator :: TopLevelIterator -> String -> IRType -> Doc Unit
callTopLevelIterator f topLevelNameGiven topLevelType = do
    topLevelName <- lookupTopLevelName topLevelNameGiven
    f topLevelName topLevelType

forEachTopLevel_ :: TopLevelIterator -> Doc Unit
forEachTopLevel_ f = do
    topLevels <- getTopLevels
    for_ (M.toUnfoldable topLevels :: List _) \(Tuple topLevelNameGiven topLevelType) ->
        callTopLevelIterator f topLevelNameGiven topLevelType

callClassIterator :: ClassIterator -> Int -> IRClassData -> Doc Unit
callClassIterator f i (IRClassData { properties }) = do
    className <- lookupClassName i
    f className properties

forEachClass_ :: ClassIterator -> Doc Unit
forEachClass_ f = do
    classes <- getClasses
    for_ classes \(Tuple i cd) ->
        callClassIterator f i cd

callUnionIterator :: UnionIterator -> IRUnionRep -> Doc Unit
callUnionIterator f ur = do
    let allTypes = unionToSet ur
    unionName <- lookupUnionName ur
    f unionName allTypes

forEachUnion_ :: UnionIterator -> Doc Unit
forEachUnion_ f = do
    unions <- getUnions
    for_ unions \ur ->
        callUnionIterator f ur

getTopLevelPlural :: Doc String
getTopLevelPlural = getForSingleOrMultipleTopLevels "" "s"

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = String.times "    " indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a

combineNames :: Named (Set String) -> String
combineNames names =
    let s = namedValue names
    in case L.fromFoldable s of
    L.Nil -> "NONAME"
    name : L.Nil -> name
    firstName : rest ->
        let a = String.toCharArray firstName
            { p, s } = L.foldl prefixSuffixFolder { p: a, s: A.reverse a } rest
            prefix = if A.length p > 2 then p else []
            suffix = if A.length s > 2 then A.reverse s else []
            name = String.fromCharArray $ A.concat [prefix, suffix]
        in
            if String.length name > 2 then
                name
            else
                firstName

commonPrefix :: Array Char -> Array Char -> Array Char
commonPrefix a b =
    let l = A.length $ A.takeWhile id $ A.zipWith eq a b
    in A.take l a

prefixSuffixFolder :: { p :: Array Char, s :: Array Char } -> String -> { p :: Array Char, s :: Array Char }
prefixSuffixFolder { p, s } x =
    let a = String.toCharArray x
        newP = commonPrefix p a
        newS = commonPrefix s (A.reverse a)
    in { p: newP, s: newS }

data RenderItem
    = RenderTopLevel String IRType
    | RenderClass Int IRClassData
    | RenderUnion IRUnionRep

derive instance eqRenderItem :: Eq RenderItem
derive instance ordRenderItem :: Ord RenderItem

sortRenderItems :: Array RenderItem -> Doc (Array RenderItem)
sortRenderItems startItems = do
    reversedSorted <- sortStep (Sq.fromFoldable startItems) L.Nil (S.fromFoldable startItems)
    pure $ A.reverse $ A.fromFoldable reversedSorted
    where
        expandUnion :: IRUnionRep -> Doc (List RenderItem)
        expandUnion ur = do
            -- FIXME: the set order is semi-random
            mapped <- mapM expandType $ L.fromFoldable $ unionToSet ur
            pure $ L.concat mapped

        expandType :: IRType -> Doc (List RenderItem)
        expandType (IRClass i) = do
            cd <- getClass i
            pure $ L.singleton $ RenderClass i cd
        expandType (IRUnion ur) = do
            unionSet <- getUnionSet
            if S.member ur unionSet
                then
                    pure $ L.singleton $ RenderUnion ur
                else
                    expandUnion ur

        expandType (IRArray a) = expandType a
        expandType (IRMap m) = expandType m
        expandType _ = pure L.Nil

        expand :: RenderItem -> Doc (List RenderItem)
        expand (RenderTopLevel _ t) =
            expandType t
        expand (RenderClass _ (IRClassData { properties })) = do
            -- FIXME: the map order is semi-random
            mapped <- mapM expandType $ M.values properties
            pure $ L.concat mapped
        expand (RenderUnion ur) =
            expandUnion ur

        filterItems :: Set RenderItem -> List RenderItem -> Seq RenderItem -> { newItems :: Seq RenderItem, newExpandedSet :: Set RenderItem }
        filterItems set L.Nil filtered =
            { newItems: filtered, newExpandedSet: set }
        filterItems set (item : otherItems) filtered =
            if S.member item set then
                filterItems set otherItems filtered
            else
                filterItems (S.insert item set) otherItems (Sq.snoc filtered item)

        sortStep :: Seq RenderItem -> List RenderItem -> Set RenderItem -> Doc (List RenderItem)
        sortStep queue soFar expandedSet =
            case Sq.uncons queue of
            Nothing ->
                pure $ soFar
            Just (Tuple item queueRest) -> do
                expandedItems <- expand item
                let { newItems, newExpandedSet } = filterItems expandedSet expandedItems Sq.empty
                let newSoFar = item : soFar
                let newQueue = Sq.append newItems queueRest
                sortStep newQueue newSoFar newExpandedSet

getRenderItems :: Doc (Array RenderItem)
getRenderItems = do
    topLevels <- map (\(Tuple n t) -> RenderTopLevel n t) <$> M.toUnfoldable <$> getTopLevels
    sortRenderItems topLevels

renderRenderItems :: Doc Unit -> TopLevelIterator -> ClassIterator -> UnionIterator -> Doc Unit
renderRenderItems inBetweener topLevelRenderer classRenderer unionRenderer = do
    renderItems <- getRenderItems
    forEnumerated_ (L.fromFoldable renderItems) \i ri -> do
        case ri of
            RenderTopLevel n t -> callTopLevelIterator topLevelRenderer n t
            RenderClass i cd -> callClassIterator classRenderer i cd
            RenderUnion ur -> callUnionIterator unionRenderer ur
        let isLast = i == (A.length renderItems) - 1
        unless isLast inBetweener

module Doc
    ( Doc
    , Renderer
    , Transforms
    , Namer
    , getTopLevels
    , getSingleTopLevel
    , getModuleName
    , getForSingleOrMultipleTopLevels
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , getTopLevelNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , lookupTopLevelName
    , forEachTopLevel_
    , forEachClass_
    , forEachUnion_
    , combineNames
    , NamingResult
    , transformNames
    , transformPropertyNames
    , simpleNamer
    , noForbidNamer
    , forbidNamer
    , unionNameIntercalated
    , unionIsNotSimpleNullable
    , getTopLevelPlural
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    , renderRenderItems
    ) where

import IR
import IRGraph
import Prelude

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Array as A
import Data.Foldable (for_, any, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, maybe, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.String.Util (times) as String
import Data.Tuple (Tuple(..), fst, snd)
import Utils (forEnumerated_, sortByKeyM)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type NamingResult = { name :: String, forbid :: Array String }
type Namer a = a -> Maybe String -> NamingResult

type Transforms =
    { nameForClass :: Namer IRClassData
    , nextName :: String -> String
    , forbiddenNames :: Array String
    , topLevelName :: Namer String
    , unions :: Maybe
        { predicate :: IRUnionRep -> Boolean
        , properName :: Namer (Named (Set String))
        , nameFromTypes :: Namer (Array String)
        }
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map IRUnionRep String
    , topLevelNames :: Map String String
    , unions :: Array IRUnionRep -- FIXME: we do we even keep this?
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph@(IRGraph { toplevels }) =
    let topLevelTuples = map (\n -> Tuple n n) $ M.keys toplevels
        forbiddenFromStart = S.fromFoldable t.forbiddenNames
        { names: topLevelNames, forbidden: forbiddenAfterTopLevels } = transformNames t.topLevelName t.nextName forbiddenFromStart topLevelTuples
        classes = classesInGraph graph
        { names: classNames, forbidden: forbiddenAfterClasses } = transformNames t.nameForClass t.nextName forbiddenAfterTopLevels classes
        { unions, unionNames } = doUnions classNames forbiddenAfterClasses
    in
        evalRWS w { graph, classNames, unionNames, topLevelNames, unions } { indent: 0 } # snd
    where
        doUnions :: Map Int String -> Set String -> { unions :: Array IRUnionRep, unionNames :: Map IRUnionRep String }
        doUnions classNames forbidden = case t.unions of
            Nothing -> { unions: [], unionNames: M.empty }
            Just { predicate, properName, nameFromTypes } ->
                let unions = A.fromFoldable $ filterTypes (unionPredicate predicate) graph
                    unionNames = (transformNames (unionNamer nameFromTypes properName classNames) t.nextName forbidden $ L.fromFoldable $ map (\s -> Tuple s s) unions).names
                in
                    { unions, unionNames }

        unionPredicate :: (IRUnionRep -> Boolean) -> IRType -> Maybe IRUnionRep
        unionPredicate p (IRUnion ur) = if p ur then Just ur else Nothing
        unionPredicate _ _ = Nothing

        unionNamer :: Namer (Array String) -> Namer (Named (Set String)) -> Map Int String -> Namer IRUnionRep
        unionNamer nameFromTypes properName classNames union@(IRUnionRep { names }) =
            if namedValue names == S.empty then
                let typeStrings = map (typeNameForUnion graph classNames) $ A.sort $ A.fromFoldable $ unionToSet union
                in
                    nameFromTypes typeStrings
            else
                properName names

transformNames :: forall a b. Ord a => Ord b => Namer b -> (String -> String) -> Set String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
transformNames legalize otherize illegalNames names =
    process S.empty illegalNames M.empty names
    where
        makeName :: b -> NamingResult -> Set String -> Set String -> NamingResult
        makeName name result@{ name: tryName, forbid } forbiddenInScope forbiddenForAll =
            if S.member tryName forbiddenInScope || any (\x -> S.member x forbiddenForAll) forbid then
                makeName name (legalize name (Just $ otherize tryName)) forbiddenInScope forbiddenForAll
            else
                result
        process :: Set String -> Set String -> Map a String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
        process forbiddenInScope forbiddenForAll mapSoFar l =
            case l of
            L.Nil -> { names: mapSoFar, forbidden: forbiddenForAll }
            (Tuple identifier inputs) : rest ->
                let { name, forbid } = makeName inputs (legalize inputs Nothing) forbiddenInScope forbiddenForAll
                    newForbiddenInScope = S.insert name forbiddenInScope
                    newForbiddenForAll = S.union (S.fromFoldable forbid) forbiddenForAll
                    newMap = M.insert identifier name mapSoFar
                in
                    process newForbiddenInScope newForbiddenForAll newMap rest

transformPropertyNames :: Namer String -> (String -> String) -> Array String -> Map String IRType -> Map String String
transformPropertyNames legalize otherize illegalNamesArray properties =
    let illegalNames = S.fromFoldable illegalNamesArray
    in
        _.names $ transformNames legalize otherize illegalNames $ map (\n -> Tuple n n) $ M.keys properties

forbidNamer :: forall a. Ord a => (a -> String) -> (String -> Array String) -> Namer a
forbidNamer namer forbidder _ (Just name) = { name, forbid: forbidder name }
forbidNamer namer forbidder x Nothing =
    let name = namer x
    in { name, forbid: forbidder name }

simpleNamer :: forall a. Ord a => (a -> String) -> Namer a
simpleNamer namer = forbidNamer namer A.singleton

noForbidNamer :: forall a. Ord a => (a -> String) -> Namer a
noForbidNamer namer = forbidNamer namer (const [])

typeNameForUnion :: IRGraph -> Map Int String -> IRType -> String
typeNameForUnion graph classNames = case _ of
    IRNothing -> "anything"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph classNames a <> "_array"
    IRClass i -> lookupName i classNames
    IRMap t -> typeNameForUnion graph classNames t <> "_map"
    IRUnion _ -> "union"

unionNameIntercalated :: (String -> String) -> String -> Array String -> String
unionNameIntercalated nameStyle orString names =
    names
    <#> nameStyle
    # intercalate orString

unionIsNotSimpleNullable :: IRUnionRep -> Boolean
unionIsNotSimpleNullable ur = isNothing $ nullableFromSet $ unionToSet ur

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  classNames <- getClassNames
  pure $ typeNameForUnion g classNames typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevels :: Doc (Map String IRType)
getTopLevels = do
    IRGraph { toplevels } <- getGraph
    pure toplevels

getSingleTopLevel :: Doc (Maybe (Tuple String IRType))
getSingleTopLevel = do
    topLevels <- getTopLevels
    case M.toUnfoldable topLevels :: List _ of
        t : L.Nil -> pure $ Just t
        _ -> pure Nothing

getModuleName :: (String -> String) -> Doc String
getModuleName nameStyler = do
    single <- getSingleTopLevel
    pure $ maybe "QuickType" (fst >>> nameStyler) single

getForSingleOrMultipleTopLevels :: forall a. a -> a -> Doc a
getForSingleOrMultipleTopLevels forSingle forMultiple = do
    single <- getSingleTopLevel
    pure $ maybe forMultiple (const forSingle) single

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List IRUnionRep)
getUnions = do
    unsorted <- M.keys <$> getUnionNames
    sortByKeyM lookupUnionName unsorted

getUnionNames :: Doc (Map IRUnionRep String)
getUnionNames = Doc (asks _.unionNames)

getTopLevelNames :: Doc (Map String String)
getTopLevelNames = Doc (asks _.topLevelNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = do
    unsorted <- classesInGraph <$> getGraph
    sortByKeyM (\t -> lookupClassName (fst t)) unsorted

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: IRUnionRep -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

lookupTopLevelName :: String -> Doc String
lookupTopLevelName n = do
    topLevelNames <- getTopLevelNames
    pure $ lookupName n topLevelNames

type TopLevelIterator = String -> IRType -> Doc Unit
type ClassIterator = String -> Map String IRType -> Doc Unit
type UnionIterator = String -> Set IRType -> Doc Unit

callTopLevelIterator :: TopLevelIterator -> String -> IRType -> Doc Unit
callTopLevelIterator f topLevelNameGiven topLevelType = do
    topLevelName <- lookupTopLevelName topLevelNameGiven
    f topLevelName topLevelType

forEachTopLevel_ :: TopLevelIterator -> Doc Unit
forEachTopLevel_ f = do
    topLevels <- getTopLevels
    for_ (M.toUnfoldable topLevels :: List _) \(Tuple topLevelNameGiven topLevelType) ->
        callTopLevelIterator f topLevelNameGiven topLevelType

callClassIterator :: ClassIterator -> Int -> IRClassData -> Doc Unit
callClassIterator f i (IRClassData { properties }) = do
    className <- lookupClassName i
    f className properties

forEachClass_ :: ClassIterator -> Doc Unit
forEachClass_ f = do
    classes <- getClasses
    for_ classes \(Tuple i cd) ->
        callClassIterator f i cd

callUnionIterator :: UnionIterator -> IRUnionRep -> Doc Unit
callUnionIterator f ur = do
    let allTypes = unionToSet ur
    unionName <- lookupUnionName ur
    f unionName allTypes

forEachUnion_ :: UnionIterator -> Doc Unit
forEachUnion_ f = do
    unions <- getUnions
    for_ unions \ur ->
        callUnionIterator f ur

getTopLevelPlural :: Doc String
getTopLevelPlural = getForSingleOrMultipleTopLevels "" "s"

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = String.times "    " indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a

combineNames :: Named (Set String) -> String
combineNames names =
    let s = namedValue names
    in case L.fromFoldable s of
    L.Nil -> "NONAME"
    name : L.Nil -> name
    firstName : rest ->
        let a = String.toCharArray firstName
            { p, s } = L.foldl prefixSuffixFolder { p: a, s: A.reverse a } rest
            prefix = if A.length p > 2 then p else []
            suffix = if A.length s > 2 then A.reverse s else []
            name = String.fromCharArray $ A.concat [prefix, suffix]
        in
            if String.length name > 2 then
                name
            else
                firstName

commonPrefix :: Array Char -> Array Char -> Array Char
commonPrefix a b =
    let l = A.length $ A.takeWhile id $ A.zipWith eq a b
    in A.take l a

prefixSuffixFolder :: { p :: Array Char, s :: Array Char } -> String -> { p :: Array Char, s :: Array Char }
prefixSuffixFolder { p, s } x =
    let a = String.toCharArray x
        newP = commonPrefix p a
        newS = commonPrefix s (A.reverse a)
    in { p: newP, s: newS }

data RenderItem
    = RenderTopLevel String IRType
    | RenderClass Int IRClassData
    | RenderUnion IRUnionRep

getRenderItems :: Doc (Array RenderItem)
getRenderItems = do
    topLevels <- map (\(Tuple n t) -> RenderTopLevel n t) <$> M.toUnfoldable <$> getTopLevels
    classes <- A.fromFoldable <$> map (\(Tuple i cd) -> RenderClass i cd) <$> getClasses
    unions <- A.fromFoldable <$> map RenderUnion <$> getUnions
    pure $ A.concat [topLevels, classes, unions]

renderRenderItems :: Doc Unit -> TopLevelIterator -> ClassIterator -> UnionIterator -> Doc Unit
renderRenderItems inBetweener topLevelRenderer classRenderer unionRenderer = do
    renderItems <- getRenderItems
    forEnumerated_ (L.fromFoldable renderItems) \i ri -> do
        case ri of
            RenderTopLevel n t -> callTopLevelIterator topLevelRenderer n t
            RenderClass i cd -> callClassIterator classRenderer i cd
            RenderUnion ur -> callUnionIterator unionRenderer ur
        let isLast = i == (A.length renderItems) - 1
        unless isLast inBetweener