Remove MonadZero instance

Remove MonadZero instance

module Test.Spec
  ( Spec
  , SpecT(..)
  , module Reexport
  , SpecTree
  , mapSpecTree
  , collect

  , ComputationType(..)
  , hoistSpec

  , class Example
  , evaluateExample

  , parallel
  , sequential

  , class FocusWarning
  , focus
  , describeOnly
  , itOnly

  , describe
  , it
  , pending
  , pending'

  , aroundWith
  , around
  , around_

  , before
  , before_
  , beforeWith
  , beforeAll
  , beforeAll_

  , after
  , after_
  , afterAll
  , afterAll_
  ) where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Monad.Cont (class MonadCont, class MonadTrans)
import Control.Monad.Error.Class (class MonadError, class MonadThrow)
import Control.Monad.Fork.Class (class MonadBracket, bracket)
import Control.Monad.Reader (class MonadAsk, class MonadReader)
import Control.Monad.Rec.Class (class MonadRec)
import Control.Monad.State (class MonadState)
import Control.Monad.Writer (WriterT, execWriterT, mapWriterT, tell)
import Control.MonadPlus (class MonadPlus)
import Control.Plus (class Plus)
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Bifunctor (bimap)
import Data.Either (Either(..), either)
import Data.Foldable (any)
import Data.Function (applyFlipped)
import Data.Identity (Identity)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, over, un)
import Effect.AVar (AVar)
import Effect.AVar as AVarEff
import Effect.Aff (Aff, error, throwError, try)
import Effect.Aff.AVar as AVar
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Prim.TypeError (class Warn, Text)
import Test.Spec.Tree (ActionWith, Item(..), Tree(..)) as Reexport
import Test.Spec.Tree (ActionWith, Item(..), Tree(..), bimapTree, discardUnfocused, modifyAroundAction)

type Spec a = SpecT Aff Unit Identity a

newtype SpecT g i m a = SpecT (WriterT (Array (SpecTree g i)) m a)

derive instance newtypeSpecT :: Newtype (SpecT g i m a) _
derive newtype instance functorSpecT :: Functor m => Functor (SpecT g i m)
derive newtype instance applySpecT :: Apply m => Apply (SpecT g i m)
derive newtype instance applicativeSpecT :: Applicative m => Applicative (SpecT g i m)
derive newtype instance altSpecT :: Alt m => Alt (SpecT g i m)
derive newtype instance plusSpecT :: Plus m => Plus (SpecT g i m)
derive newtype instance alternativeSpecT :: (Alternative m) => Alternative (SpecT g i m)
derive newtype instance bindSpecT :: Bind m => Bind (SpecT g i m)
derive newtype instance monadSpecT :: Monad m => Monad (SpecT g i m)
derive newtype instance monadRecSpecT :: MonadRec m => MonadRec (SpecT g i m)
derive newtype instance monadPlusSpecT :: MonadPlus m => MonadPlus (SpecT g i m)
derive newtype instance monadTransSpecT :: MonadTrans (SpecT g i)
derive newtype instance monadEffectWriter :: MonadEffect m => MonadEffect (SpecT g i m)
derive newtype instance monadContSpecT :: MonadCont m => MonadCont (SpecT g i m)
derive newtype instance monadThrowSpecT :: MonadThrow e m => MonadThrow e (SpecT g i m)
derive newtype instance monadErrorSpecT :: MonadError e m => MonadError e (SpecT g i m)
derive newtype instance monadAskSpecT :: MonadAsk r m => MonadAsk r (SpecT g i m)
derive newtype instance monadReaderSpecT :: MonadReader r m => MonadReader r (SpecT g i m)
derive newtype instance monadStateSpecT :: MonadState s m => MonadState s (SpecT g i m)

type SpecTree m a = Tree (ActionWith m a) (Item m a)

mapSpecTree
  :: forall m m' g g' i a i'
   . Functor m'
   => (m ~> m')
   -> (SpecTree g i -> SpecTree g' i')
   -> SpecT g i m a
   -> SpecT g' i' m' a
mapSpecTree g f = over SpecT $ mapWriterT $ g >>> map (map $ map f)

data ComputationType = CleanUpWithContext (Array String) | TestWithName (NonEmptyArray String)

hoistSpec :: forall m' m i a b. Monad m' => (m ~> m') -> (ComputationType -> a ~> b) -> SpecT a i m ~> SpecT b i m'
hoistSpec onM f = mapSpecTree onM $ bimapTree onCleanUp onTest
  where
    onCleanUp :: Array String -> (ActionWith a i) -> ActionWith b i
    onCleanUp name around' = \i -> f (CleanUpWithContext name) (around' i)
    onTest :: NonEmptyArray String -> Item a i -> Item b i
    onTest name = over Item \item ->
      let
        e :: ((i -> b Unit) -> b Unit) -> b Unit
        e g = g (f (TestWithName name) <<< item.example <<< applyFlipped)
      in item { example = e }

-- | Collects all tests, if something is focused, all unfocused tests will be discarded
collect :: forall m g i a. Functor m => SpecT g i m a -> m (Array (SpecTree g i))
collect = un SpecT >>> execWriterT >>> map discardUnfocused

class Example t arg m | t -> arg, t -> m where
  evaluateExample :: t -> (ActionWith m arg -> m Unit) -> m Unit

instance exampleFunc :: Example (arg -> m Unit) arg m where
  evaluateExample :: (arg -> m Unit) -> (ActionWith m arg -> m Unit) -> m Unit
  evaluateExample t around' = around' t

else instance exampleMUnit :: Example (m Unit) Unit m where
  evaluateExample :: (m Unit) -> (ActionWith m Unit -> m Unit) -> m Unit
  evaluateExample t around' = around' $ \_ -> t

-- | Nullary class used to raise a custom warning for the focusing functions.
class FocusWarning

instance warn :: Warn (Text "Test.Spec.focus usage") => FocusWarning

-- ---------------------
-- --       DSL       --
-- ---------------------

-- | `focus` focuses all spec items of the given spec.
-- |
-- | Applying `focus` to a spec with focused spec items has no effect.
focus :: forall m g i a. FocusWarning => Monad m => SpecT g i m a -> SpecT g i m a
focus = over SpecT $ mapWriterT $ map $ map \xs ->
  if any (any $ un Item >>> _.isFocused) xs
    then xs
    else map (bimap identity (\(Item r) -> Item r {isFocused = true})) xs

-- | Combine a group of specs into a described hierarchy.
describe
  :: forall m g i a
   . Monad m
  => String
  -> SpecT g i m a
  -> SpecT g i m a
describe name = over SpecT $ mapWriterT $ map $ map \group -> [Node (Left name) group]

-- | Combine a group of specs into a described hierarchy and mark it as the
-- | only group to actually be evaluated. (useful for quickly narrowing down
-- | on a set)
describeOnly
  :: forall m g i a
   . FocusWarning
  => Monad m
  => String
  -> SpecT g i m a
  -> SpecT g i m a
describeOnly = map focus <<< describe

-- | marks all spec items of the given spec to be safe for parallel evaluation.
parallel
  :: forall m g i a
   . Monad m
  => SpecT g i m a
  -> SpecT g i m a
parallel = mapSpecTree identity $ bimap identity (setParallelizable true)

-- | marks all spec items of the given spec to be evaluated sequentially.
sequential
  :: forall m g i a
   . Monad m
  => SpecT g i m a
  -> SpecT g i m a
sequential = mapSpecTree identity $ bimap identity (setParallelizable false)

setParallelizable :: forall g a. Boolean -> Item g a -> Item g a
setParallelizable value = over Item \i -> i{isParallelizable = i.isParallelizable <|> Just value}

-- | Create a pending spec.
pending
  :: forall m g i
   . Monad m
  => String
  -> SpecT g i m Unit
pending name = SpecT $ tell [Leaf name Nothing]

-- | Create a pending spec with a body that is ignored by
-- | the runner. It can be useful for documenting what the
-- | spec should test when non-pending.
pending'
  :: forall m g i
   . Monad m
  => String
  -> g Unit
  -> SpecT g i m Unit
pending' name _ = pending name

-- | Create a spec with a description.
it
  :: forall m t arg g
   . Monad m
  => Example t arg g
  => String
  -> t
  -> SpecT g arg m Unit
it name test = SpecT $ tell
  [ Leaf name $ Just $ Item
      { isParallelizable: Nothing
      , isFocused: false
      , example: evaluateExample test
      }
  ]

-- | Create a spec with a description and mark it as the only one to
-- | be run. (useful for quickly narrowing down on a single test)
itOnly
  :: forall m t arg g
   . FocusWarning
  => Monad m
  => Example t arg g
  => String
  -> t
  -> SpecT g arg m Unit
itOnly = map focus <<< it

-- ---------------------
-- --      HOOKS      --
-- ---------------------

-- | Run a custom action before and/or after every spec item.
aroundWith
  :: forall m g i i' a
   . Monad m
  => (ActionWith g i -> ActionWith g i')
  -> SpecT g i m a
  -> SpecT g i' m a
aroundWith action = mapSpecTree identity $ bimap action (modifyAroundAction action)

-- | Run a custom action before and/or after every spec item.
around_ :: forall m g i a. Monad m => (g Unit -> g Unit) -> SpecT g i m a -> SpecT g i m a
around_ action = aroundWith $ \e a -> action (e a)

-- | Run a custom action after every spec item.
after :: forall m g e f i a. Monad m => MonadBracket e f g => ActionWith g i -> SpecT g i m a -> SpecT g i m a
after action = aroundWith $ \e x -> e x `finally` action x
  where
  finally :: forall x. g x -> g Unit -> g x
  finally act fin = bracket (pure unit) (\_ _ -> fin) (const act)

-- | Run a custom action after every spec item.
after_ :: forall m g e f i a. Monad m => MonadBracket e f g => g Unit -> SpecT g i m a -> SpecT g i m a
after_ action = after $ \_ -> action

-- | Run a custom action before and/or after every spec item.
around :: forall m g i a. Monad m => (ActionWith g i -> g Unit) -> SpecT g i m a -> SpecT g Unit m a
around action = aroundWith $ \e _ -> action e

-- | Run a custom action before every spec item.
before :: forall m g i a. Monad m => Monad g => g i -> SpecT g i m a -> SpecT g Unit m a
before action = around (action >>= _)

-- | Run a custom action before every spec item.
before_ :: forall m g i a. Monad m => Monad g => g Unit -> SpecT g i m a -> SpecT g i m a
before_ action = around_ (action *> _)

-- | Run a custom action before every spec item.
beforeWith :: forall m g i i' a. Monad m => Monad g => (i' -> g i) -> SpecT g i m a -> SpecT g i' m a
beforeWith action = aroundWith $ \e x -> action x >>= e

-- | Run a custom action before the first spec item.
beforeAll :: forall m g i a. MonadEffect m => MonadAff g => MonadError Error g => g i -> SpecT g i m a -> SpecT g Unit m a
beforeAll action spec = do
  var <- liftEffect $ AVarEff.new MEmpty
  before (memoize var action) spec

-- | Run a custom action before the first spec item.
beforeAll_ :: forall m g i a. MonadEffect m => MonadAff g => MonadError Error g => g Unit -> SpecT g i m a -> SpecT g i m a
beforeAll_ action spec = do
  var <- liftEffect $ AVarEff.new MEmpty
  before_ (memoize var action) spec

data Memoized a
  = MEmpty
  | MMemoized a
  | MFailed Error

memoize :: forall a m. MonadAff m => MonadError Error m => AVar (Memoized a) -> m a -> m a
memoize var action = do
  liftAff (AVar.take var) >>= case _ of
    MFailed _ -> throwError $ error "exception in beforeAll-hook (see previous failure)"
    MMemoized x -> pure x <* (liftAff $ AVar.put (MMemoized x) var)
    MEmpty -> do
      res <- try action
      liftAff $ AVar.put (either MFailed MMemoized res) var
      either throwError pure res

-- | Run a custom action after the last spec item.
afterAll :: forall m g i a. Monad m => ActionWith g i -> SpecT g i m a -> SpecT g i m a
afterAll action = over SpecT $ mapWriterT $ map $ map \group -> [Node (Right action) group]

-- | Run a custom action after the last spec item.
afterAll_ :: forall m g i a. Monad m => g Unit -> SpecT g i m a -> SpecT g i m a
afterAll_ action = afterAll $ const action

module Test.Spec
  ( Spec
  , SpecT(..)
  , module Reexport
  , SpecTree
  , mapSpecTree
  , collect

  , ComputationType(..)
  , hoistSpec

  , class Example
  , evaluateExample

  , parallel
  , sequential

  , class FocusWarning
  , focus
  , describeOnly
  , itOnly

  , describe
  , it
  , pending
  , pending'

  , aroundWith
  , around
  , around_

  , before
  , before_
  , beforeWith
  , beforeAll
  , beforeAll_

  , after
  , after_
  , afterAll
  , afterAll_
  ) where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Monad.Cont (class MonadCont, class MonadTrans)
import Control.Monad.Error.Class (class MonadError, class MonadThrow)
import Control.Monad.Fork.Class (class MonadBracket, bracket)
import Control.Monad.Reader (class MonadAsk, class MonadReader)
import Control.Monad.Rec.Class (class MonadRec)
import Control.Monad.State (class MonadState)
import Control.Monad.Writer (WriterT, execWriterT, mapWriterT, tell)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Bifunctor (bimap)
import Data.Either (Either(..), either)
import Data.Foldable (any)
import Data.Function (applyFlipped)
import Data.Identity (Identity)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, over, un)
import Effect.AVar (AVar)
import Effect.AVar as AVarEff
import Effect.Aff (Aff, error, throwError, try)
import Effect.Aff.AVar as AVar
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Prim.TypeError (class Warn, Text)
import Test.Spec.Tree (ActionWith, Item(..), Tree(..)) as Reexport
import Test.Spec.Tree (ActionWith, Item(..), Tree(..), bimapTree, discardUnfocused, modifyAroundAction)

type Spec a = SpecT Aff Unit Identity a

newtype SpecT g i m a = SpecT (WriterT (Array (SpecTree g i)) m a)

derive instance newtypeSpecT :: Newtype (SpecT g i m a) _
derive newtype instance functorSpecT :: Functor m => Functor (SpecT g i m)
derive newtype instance applySpecT :: Apply m => Apply (SpecT g i m)
derive newtype instance applicativeSpecT :: Applicative m => Applicative (SpecT g i m)
derive newtype instance altSpecT :: Alt m => Alt (SpecT g i m)
derive newtype instance plusSpecT :: Plus m => Plus (SpecT g i m)
derive newtype instance alternativeSpecT :: (Alternative m) => Alternative (SpecT g i m)
derive newtype instance bindSpecT :: Bind m => Bind (SpecT g i m)
derive newtype instance monadSpecT :: Monad m => Monad (SpecT g i m)
derive newtype instance monadRecSpecT :: MonadRec m => MonadRec (SpecT g i m)
derive newtype instance monadZeroSpecT :: MonadZero m => MonadZero (SpecT g i m)
derive newtype instance monadPlusSpecT :: MonadPlus m => MonadPlus (SpecT g i m)
derive newtype instance monadTransSpecT :: MonadTrans (SpecT g i)
derive newtype instance monadEffectWriter :: MonadEffect m => MonadEffect (SpecT g i m)
derive newtype instance monadContSpecT :: MonadCont m => MonadCont (SpecT g i m)
derive newtype instance monadThrowSpecT :: MonadThrow e m => MonadThrow e (SpecT g i m)
derive newtype instance monadErrorSpecT :: MonadError e m => MonadError e (SpecT g i m)
derive newtype instance monadAskSpecT :: MonadAsk r m => MonadAsk r (SpecT g i m)
derive newtype instance monadReaderSpecT :: MonadReader r m => MonadReader r (SpecT g i m)
derive newtype instance monadStateSpecT :: MonadState s m => MonadState s (SpecT g i m)

type SpecTree m a = Tree (ActionWith m a) (Item m a)

mapSpecTree
  :: forall m m' g g' i a i'
   . Functor m'
   => (m ~> m')
   -> (SpecTree g i -> SpecTree g' i')
   -> SpecT g i m a
   -> SpecT g' i' m' a
mapSpecTree g f = over SpecT $ mapWriterT $ g >>> map (map $ map f)

data ComputationType = CleanUpWithContext (Array String) | TestWithName (NonEmptyArray String)

hoistSpec :: forall m' m i a b. Monad m' => (m ~> m') -> (ComputationType -> a ~> b) -> SpecT a i m ~> SpecT b i m'
hoistSpec onM f = mapSpecTree onM $ bimapTree onCleanUp onTest
  where
    onCleanUp :: Array String -> (ActionWith a i) -> ActionWith b i
    onCleanUp name around' = \i -> f (CleanUpWithContext name) (around' i)
    onTest :: NonEmptyArray String -> Item a i -> Item b i
    onTest name = over Item \item ->
      let
        e :: ((i -> b Unit) -> b Unit) -> b Unit
        e g = g (f (TestWithName name) <<< item.example <<< applyFlipped)
      in item { example = e }

-- | Collects all tests, if something is focused, all unfocused tests will be discarded
collect :: forall m g i a. Functor m => SpecT g i m a -> m (Array (SpecTree g i))
collect = un SpecT >>> execWriterT >>> map discardUnfocused

class Example t arg m | t -> arg, t -> m where
  evaluateExample :: t -> (ActionWith m arg -> m Unit) -> m Unit

instance exampleFunc :: Example (arg -> m Unit) arg m where
  evaluateExample :: (arg -> m Unit) -> (ActionWith m arg -> m Unit) -> m Unit
  evaluateExample t around' = around' t

else instance exampleMUnit :: Example (m Unit) Unit m where
  evaluateExample :: (m Unit) -> (ActionWith m Unit -> m Unit) -> m Unit
  evaluateExample t around' = around' $ \_ -> t

-- | Nullary class used to raise a custom warning for the focusing functions.
class FocusWarning

instance warn :: Warn (Text "Test.Spec.focus usage") => FocusWarning

-- ---------------------
-- --       DSL       --
-- ---------------------

-- | `focus` focuses all spec items of the given spec.
-- |
-- | Applying `focus` to a spec with focused spec items has no effect.
focus :: forall m g i a. FocusWarning => Monad m => SpecT g i m a -> SpecT g i m a
focus = over SpecT $ mapWriterT $ map $ map \xs ->
  if any (any $ un Item >>> _.isFocused) xs
    then xs
    else map (bimap identity (\(Item r) -> Item r {isFocused = true})) xs

-- | Combine a group of specs into a described hierarchy.
describe
  :: forall m g i a
   . Monad m
  => String
  -> SpecT g i m a
  -> SpecT g i m a
describe name = over SpecT $ mapWriterT $ map $ map \group -> [Node (Left name) group]

-- | Combine a group of specs into a described hierarchy and mark it as the
-- | only group to actually be evaluated. (useful for quickly narrowing down
-- | on a set)
describeOnly
  :: forall m g i a
   . FocusWarning
  => Monad m
  => String
  -> SpecT g i m a
  -> SpecT g i m a
describeOnly = map focus <<< describe

-- | marks all spec items of the given spec to be safe for parallel evaluation.
parallel
  :: forall m g i a
   . Monad m
  => SpecT g i m a
  -> SpecT g i m a
parallel = mapSpecTree identity $ bimap identity (setParallelizable true)

-- | marks all spec items of the given spec to be evaluated sequentially.
sequential
  :: forall m g i a
   . Monad m
  => SpecT g i m a
  -> SpecT g i m a
sequential = mapSpecTree identity $ bimap identity (setParallelizable false)

setParallelizable :: forall g a. Boolean -> Item g a -> Item g a
setParallelizable value = over Item \i -> i{isParallelizable = i.isParallelizable <|> Just value}

-- | Create a pending spec.
pending
  :: forall m g i
   . Monad m
  => String
  -> SpecT g i m Unit
pending name = SpecT $ tell [Leaf name Nothing]

-- | Create a pending spec with a body that is ignored by
-- | the runner. It can be useful for documenting what the
-- | spec should test when non-pending.
pending'
  :: forall m g i
   . Monad m
  => String
  -> g Unit
  -> SpecT g i m Unit
pending' name _ = pending name

-- | Create a spec with a description.
it
  :: forall m t arg g
   . Monad m
  => Example t arg g
  => String
  -> t
  -> SpecT g arg m Unit
it name test = SpecT $ tell
  [ Leaf name $ Just $ Item
      { isParallelizable: Nothing
      , isFocused: false
      , example: evaluateExample test
      }
  ]

-- | Create a spec with a description and mark it as the only one to
-- | be run. (useful for quickly narrowing down on a single test)
itOnly
  :: forall m t arg g
   . FocusWarning
  => Monad m
  => Example t arg g
  => String
  -> t
  -> SpecT g arg m Unit
itOnly = map focus <<< it

-- ---------------------
-- --      HOOKS      --
-- ---------------------

-- | Run a custom action before and/or after every spec item.
aroundWith
  :: forall m g i i' a
   . Monad m
  => (ActionWith g i -> ActionWith g i')
  -> SpecT g i m a
  -> SpecT g i' m a
aroundWith action = mapSpecTree identity $ bimap action (modifyAroundAction action)

-- | Run a custom action before and/or after every spec item.
around_ :: forall m g i a. Monad m => (g Unit -> g Unit) -> SpecT g i m a -> SpecT g i m a
around_ action = aroundWith $ \e a -> action (e a)

-- | Run a custom action after every spec item.
after :: forall m g e f i a. Monad m => MonadBracket e f g => ActionWith g i -> SpecT g i m a -> SpecT g i m a
after action = aroundWith $ \e x -> e x `finally` action x
  where
  finally :: forall x. g x -> g Unit -> g x
  finally act fin = bracket (pure unit) (\_ _ -> fin) (const act)

-- | Run a custom action after every spec item.
after_ :: forall m g e f i a. Monad m => MonadBracket e f g => g Unit -> SpecT g i m a -> SpecT g i m a
after_ action = after $ \_ -> action

-- | Run a custom action before and/or after every spec item.
around :: forall m g i a. Monad m => (ActionWith g i -> g Unit) -> SpecT g i m a -> SpecT g Unit m a
around action = aroundWith $ \e _ -> action e

-- | Run a custom action before every spec item.
before :: forall m g i a. Monad m => Monad g => g i -> SpecT g i m a -> SpecT g Unit m a
before action = around (action >>= _)

-- | Run a custom action before every spec item.
before_ :: forall m g i a. Monad m => Monad g => g Unit -> SpecT g i m a -> SpecT g i m a
before_ action = around_ (action *> _)

-- | Run a custom action before every spec item.
beforeWith :: forall m g i i' a. Monad m => Monad g => (i' -> g i) -> SpecT g i m a -> SpecT g i' m a
beforeWith action = aroundWith $ \e x -> action x >>= e

-- | Run a custom action before the first spec item.
beforeAll :: forall m g i a. MonadEffect m => MonadAff g => MonadError Error g => g i -> SpecT g i m a -> SpecT g Unit m a
beforeAll action spec = do
  var <- liftEffect $ AVarEff.new MEmpty
  before (memoize var action) spec

-- | Run a custom action before the first spec item.
beforeAll_ :: forall m g i a. MonadEffect m => MonadAff g => MonadError Error g => g Unit -> SpecT g i m a -> SpecT g i m a
beforeAll_ action spec = do
  var <- liftEffect $ AVarEff.new MEmpty
  before_ (memoize var action) spec

data Memoized a
  = MEmpty
  | MMemoized a
  | MFailed Error

memoize :: forall a m. MonadAff m => MonadError Error m => AVar (Memoized a) -> m a -> m a
memoize var action = do
  liftAff (AVar.take var) >>= case _ of
    MFailed _ -> throwError $ error "exception in beforeAll-hook (see previous failure)"
    MMemoized x -> pure x <* (liftAff $ AVar.put (MMemoized x) var)
    MEmpty -> do
      res <- try action
      liftAff $ AVar.put (either MFailed MMemoized res) var
      either throwError pure res

-- | Run a custom action after the last spec item.
afterAll :: forall m g i a. Monad m => ActionWith g i -> SpecT g i m a -> SpecT g i m a
afterAll action = over SpecT $ mapWriterT $ map $ map \group -> [Node (Right action) group]

-- | Run a custom action after the last spec item.
afterAll_ :: forall m g i a. Monad m => g Unit -> SpecT g i m a -> SpecT g i m a
afterAll_ action = afterAll $ const action


Avoid using regular expressions for base parsers

-- |
-- | This module defines commonly used Parser-combinators
-- |

module Language.Docopt.SpecParser.Base where

import Prelude
import Control.Alt ((<|>))
import Data.List (List(), many)
import Text.Parsing.Parser (PState(..), ParserT(..)) as P
import Text.Parsing.Parser.Pos (Position(..)) as P
import Text.Parsing.Parser.String (satisfy, char, string) as P
import Data.String.Regex as Regex
import Data.Array as A
import Data.Char (toString, toLower, toUpper, toCharCode)
import Data.String (toCharArray, fromCharArray)
import Data.Maybe (Maybe(Nothing, Just))
import Data.Either (Either(Right))
import Debug.Trace (traceShow)
import Control.MonadPlus (guard)

debug :: forall a m. (Show a, Monad m) => a -> m Unit
debug x = traceShow x $ const $ pure unit

-- | Return the current parser position
getPosition :: forall a m. (Monad m) => P.ParserT a m P.Position
getPosition = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  pure { input: s, result: Right pos, consumed: false, position: pos }

sof :: forall a m. (Monad m) => P.ParserT a m Unit
sof = do
  P.Position { column, line } <- getPosition
  guard $ column == 1 && line == 1

-- | Return the current parser column
getCol :: forall a m. (Monad m) => P.ParserT a m Int
getCol = do
  P.Position { column: col } <- getPosition
  pure col

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getRow :: forall a m. (Monad m) => P.ParserT a m Int
getRow = do
  P.Position { line: row } <- getPosition
  pure row

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getLine :: forall a m. (Monad m) => P.ParserT a m Int
getLine = getRow

tryMaybe :: forall s m a. (Monad m) => P.ParserT s m a -> P.ParserT s m (Maybe a)
tryMaybe p = (Just <$> p) <|> (pure Nothing)

-- | Return the current parser position
getInput :: forall a m. (Monad m, Show a) => P.ParserT a m a
getInput = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  pure { input: s, result: Right s, consumed: false, position: pos }

traceInput :: forall a m. (Show a, Monad m) => P.ParserT a m Unit
traceInput = getInput >>= debug

regex :: forall m. (Monad m) => String -> P.ParserT String m Char
regex s = P.satisfy \c ->
  Regex.test (Regex.regex s Regex.noFlags) (toString c)

satisfyCode :: forall m. (Monad m) => (Int -> Boolean) -> P.ParserT String m Char
satisfyCode f = P.satisfy \c -> f (toCharCode c)

isDigit :: Int -> Boolean
isDigit c = c > 47 && c < 58

isLowerAlpha :: Int -> Boolean
isLowerAlpha c = c > 96 && c < 123

isUpperAlpha :: Int -> Boolean
isUpperAlpha c = c > 64 && c < 91

lower :: forall m. (Monad m) => P.ParserT String m Char
lower = P.satisfy \c -> c == toLower c

upper :: forall m. (Monad m) => P.ParserT String m Char
upper = P.satisfy \c -> c == toUpper c

digit :: forall m. (Monad m) => P.ParserT String m Char
digit = satisfyCode \c -> c > 47 && c < 58

alpha :: forall m. (Monad m) => P.ParserT String m Char
alpha = satisfyCode \c -> (c > 64 && c < 91) || (c > 96 && c < 123)

upperAlpha :: forall m. (Monad m) => P.ParserT String m Char
upperAlpha = satisfyCode isUpperAlpha

lowerAlpha :: forall m. (Monad m) => P.ParserT String m Char
lowerAlpha = satisfyCode isLowerAlpha

lowerAlphaNum :: forall m. (Monad m) => P.ParserT String m Char
lowerAlphaNum = satisfyCode \c -> isLowerAlpha c || isDigit c

upperAlphaNum :: forall m. (Monad m) => P.ParserT String m Char
upperAlphaNum = satisfyCode \c -> isUpperAlpha c || isDigit c

alphaNum :: forall m. (Monad m) => P.ParserT String m Char
alphaNum = satisfyCode \c -> isUpperAlpha c || isLowerAlpha c || isDigit c

space :: forall m. (Monad m) => P.ParserT String m Char
space = P.satisfy \c -> c == ' ' || c == '\t'

spaces :: forall m. (Monad m) => P.ParserT String m (List Char)
spaces = many space

eol :: forall m. (Monad m) => P.ParserT String m Unit
eol = (void $ P.string "\r\n") <|> (void $ P.char '\n')

string' :: forall m. (Monad m) => String -> P.ParserT String m String
string' s = fromCharArray <$> A.foldM step [] (toCharArray s)
  where
    step acc x = do
      (acc <> _) <<< A.singleton <$> P.satisfy \c -> toLower c == toLower x

-- |
-- | This module defines commonly used Parser-combinators
-- |

module Language.Docopt.SpecParser.Base where

import Prelude
import Control.Alt ((<|>))
import Data.List (List(), many)
import Text.Parsing.Parser (PState(..), ParserT(..)) as P
import Text.Parsing.Parser.Pos (Position(..)) as P
import Text.Parsing.Parser.String (satisfy, char, string) as P
import Data.String.Regex as Regex
import Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (toCharArray, fromCharArray)
import Data.Maybe (Maybe(Nothing, Just))
import Data.Either (Either(Right))
import Debug.Trace (traceShow)
import Control.MonadPlus (guard)

debug :: forall a m. (Show a, Monad m) => a -> m Unit
debug x = traceShow x $ const $ pure unit

-- | Return the current parser position
getPosition :: forall a m. (Monad m) => P.ParserT a m P.Position
getPosition = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  pure { input: s, result: Right pos, consumed: false, position: pos }

sof :: forall a m. (Monad m) => P.ParserT a m Unit
sof = do
  P.Position { column, line } <- getPosition
  guard $ column == 1 && line == 1

-- | Return the current parser column
getCol :: forall a m. (Monad m) => P.ParserT a m Int
getCol = do
  P.Position { column: col } <- getPosition
  pure col

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getRow :: forall a m. (Monad m) => P.ParserT a m Int
getRow = do
  P.Position { line: row } <- getPosition
  pure row

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getLine :: forall a m. (Monad m) => P.ParserT a m Int
getLine = getRow

tryMaybe :: forall s m a. (Monad m) => P.ParserT s m a -> P.ParserT s m (Maybe a)
tryMaybe p = (Just <$> p) <|> (pure Nothing)

-- | Return the current parser position
getInput :: forall a m. (Monad m, Show a) => P.ParserT a m a
getInput = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  pure { input: s, result: Right s, consumed: false, position: pos }

traceInput :: forall a m. (Show a, Monad m) => P.ParserT a m Unit
traceInput = getInput >>= debug

regex :: forall m. (Monad m) => String -> P.ParserT String m Char
regex s = P.satisfy \c ->
  Regex.test (Regex.regex s Regex.noFlags) (toString c)

lower :: forall m. (Monad m) => P.ParserT String m Char
lower = P.satisfy \c -> c == toLower c

upper :: forall m. (Monad m) => P.ParserT String m Char
upper = P.satisfy \c -> c == toUpper c

digit :: forall m. (Monad m) => P.ParserT String m Char
digit = regex "[0-9]"

alpha :: forall m. (Monad m) => P.ParserT String m Char
alpha = regex "[a-zA-Z]"

upperAlpha :: forall m. (Monad m) => P.ParserT String m Char
upperAlpha = regex "[A-Z]"

lowerAlpha :: forall m. (Monad m) => P.ParserT String m Char
lowerAlpha = regex "[a-z]"

lowerAlphaNum :: forall m. (Monad m) => P.ParserT String m Char
lowerAlphaNum = regex "[0-9a-z]"

upperAlphaNum :: forall m. (Monad m) => P.ParserT String m Char
upperAlphaNum = regex "[0-9A-Z]"

alphaNum :: forall m. (Monad m) => P.ParserT String m Char
alphaNum = alpha <|> digit

space :: forall m. (Monad m) => P.ParserT String m Char
space = P.satisfy \c -> c == ' ' || c == '\t'

spaces :: forall m. (Monad m) => P.ParserT String m (List Char)
spaces = many space

eol :: forall m. (Monad m) => P.ParserT String m Unit
eol = (void $ P.string "\r\n") <|> (void $ P.char '\n')

string' :: forall m. (Monad m) => String -> P.ParserT String m String
string' s = fromCharArray <$> A.foldM step [] (toCharArray s)
  where
    step acc x = do
      (acc <> _) <<< A.singleton <$> P.satisfy \c -> toLower c == toLower x


Break up handler

Break up handler

-- | File component main handler
module Controller.File
  ( handler
  , getDirectories
  , selectThis
  , rename
  , checkRename
  , renameItemClicked
  , breadcrumbClicked
  ) where

import Control.Apply
import Control.Inject1 (Inject1, inj)
import Control.Monad.Aff.Class
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Random
import Control.Monad.Error.Class
import Control.Monad.Trans
import Control.Plus (empty)
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable
import Data.Maybe
import Data.Traversable
import Data.Tuple
import DOM
import EffectTypes
import Input.File.Item (ItemInput(..))
import Input.File.Rename (RenameInput(..))
import Input.File.Search (SearchInput(..))
import Model.DialogResume
import Model.Breadcrumb
import Model.Sort
import Model.Search
import qualified Api.Fs as Api
import qualified Config as Config
import qualified Control.Monad.Aff as Aff
import qualified Control.Timer as Tm
import qualified Control.UI.ZClipboard as Z
import qualified Data.Array as A
import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import qualified Driver.File as Cd
import qualified Halogen as Hl
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.HTML.Events.Types as Et
import qualified Model.File as M
import qualified Model.Item as Mi
import qualified Model.Notebook as Mn
import qualified Model.Resource as Mr
import qualified Network.HTTP.Affjax as Af
import qualified Routing.Hash as Rh
import qualified Text.SlamSearch as S
import qualified Utils as U
import qualified Utils.Event as Ue
import qualified Utils.File as Uf

toInput :: forall m a b. (Applicative m, Inject1 a b) => a -> m b
toInput = pure <<< inj

handleDeleteItem :: forall e. Mi.Item -> E.Event (FileAppEff e) M.Input
handleDeleteItem item = E.async $ do
  Api.deleteItem item
  toInput $ ItemRemove item

handleCreateNotebook :: forall e. M.State -> E.Event (FileAppEff e) M.Input
handleCreateNotebook state = do
  let name = getNewName Config.newNotebookName state
  path <- liftEff $ Cd.getPath <$> Rh.getHash
  let notebook = Mi.initNotebook{root = path, name = name, phantom = true}
  -- immidiately updating state and then
  (toInput $ ItemAdd notebook) `E.andThen` \_ -> do
    f <- liftAff $ Aff.attempt $ Api.makeNotebook notebook Mn.newNotebook
    (toInput $ ItemRemove notebook) `E.andThen` \_ ->  do
      case f of
        Left _ -> empty
        Right _ -> do
          liftEff $ open notebook{phantom = false} false
          -- and add real notebook to list
          toInput $ ItemAdd notebook{phantom = false}

handleFileListChanged :: forall e. Node -> M.State -> E.Event (FileAppEff e) M.Input
handleFileListChanged node state = do
  fileArr <- Uf.fileListToArray <$> (liftAff $ Uf.files node)
  liftEff $ U.clearValue node
  case A.head fileArr of
    Nothing ->
      let err :: Aff.Aff (FileAppEff e) M.Input
          err = throwError $ error "empty filelist"
      in liftAff err
    Just file -> do
      let newReader :: Eff (FileAppEff e) _
          newReader = Uf.newReaderEff

          readAsBinaryString :: _ -> _ -> Aff.Aff (FileAppEff e) _
          readAsBinaryString = Uf.readAsBinaryString

      path <- liftEff (Cd.getPath <$> Rh.getHash)
      name <- flip getNewName state <$> (liftEff $ Uf.name file)
      let fileItem = Mi.initFile{root = path, name = name, phantom = true}

      reader <- liftEff newReader
      content <- liftAff $ readAsBinaryString file reader

      (toInput $ ItemAdd fileItem) `E.andThen` \_ -> do
        f <- liftAff $ Aff.attempt $ Api.makeFile fileItem content
        (toInput $ ItemRemove fileItem) `E.andThen` \_ -> do
          case f of
            Left _ -> empty
            Right _ -> do
              liftEff $ open fileItem{phantom = false} false
              toInput $ ItemAdd fileItem{phantom = false}

handleMoveItem :: forall e. Mi.Item -> E.Event (FileAppEff e) M.Input
handleMoveItem item = do
  (toInput $ M.SetDialog (Just (RenameDialog $ initialRenameDialog item)))
    `E.andThen` \_ -> do
    getDirectories "/"

handleSetSort :: forall e. Sort -> E.Event (FileAppEff e) M.Input
handleSetSort sort = do
  liftEff $ Rh.modifyHash $ Cd.updateSort sort
  empty

handleOpenItem :: forall e. Mi.Item -> E.Event (FileAppEff e) M.Input
handleOpenItem item = do
  liftEff $ case item.resource of
    Mr.Directory ->
      moveDown item
    Mr.Database ->
      moveDown item
    Mr.File ->
      open item true
    Mr.Table ->
      open item true
    Mr.Notebook ->
      open item false
  empty

handleUploadFile :: forall e. Node -> E.Event (FileAppEff e) M.Input
handleUploadFile node = do
  let el = U.convertToElement node
  mbInput <- liftEff $ querySelector "input" el
  case mbInput of
    Nothing -> empty
    Just input -> do
      liftEff $ Ue.raiseEvent "click" input
      empty

-- | clicked on _Folder_ link, create phantom folder
handleCreateFolder :: forall e. M.State -> E.Event (FileAppEff e) M.Input
handleCreateFolder state = do
  let name = getNewName Config.newFolderName state
  path <- liftEff (Cd.getPath <$> Rh.getHash)
  toInput $ ItemAdd $ Mi.initDirectory { root = path, name = name }

handleMountDatabase :: forall e. E.Event (FileAppEff e) M.Input
handleMountDatabase = toInput $ M.SetDialog (Just MountDialog)

handleConfigure :: forall e. E.Event (FileAppEff e) M.Input
handleConfigure = toInput $ M.SetDialog (Just ConfigureDialog)

handleSearchClear :: forall e. Boolean -> Search -> E.Event (FileAppEff e) M.Input
handleSearchClear isSearching search = do
  liftEff $ maybe (pure unit) Tm.clearTimeout search.timeout
  if isSearching then do
    rnd <- show <$> (liftEff $ randomInt 1000000 2000000)
    liftEff (Rh.modifyHash $ Cd.updateSalt rnd)
    toInput $ M.Loading false
    else
    setQE "path:/"

-- TODO: String/Path type alias? Maybe a real path when new library is done
handleSearchChange :: forall e. Search -> String -> String -> E.Event (FileAppEff e) M.Input
handleSearchChange search ch path = E.async $ Aff.makeAff $ \_ k -> do
    k $ inj $ SearchNextValue ch
    maybe (pure unit) Tm.clearTimeout search.timeout
    tim <- Tm.timeout Config.searchTimeout $ do
      E.runEvent (const $ pure unit) (const $ pure unit) $
        setQE (ch <> " path:\"" <> path <> "\"")
    k $ inj $ SearchTimeout tim
    k $ inj $ SearchValidation true

  -- ATTENTION
  -- This works too slow
  --      (toInput $ M.SearchNextValue ch) `E.andThen` \_ -> do
  --        tim <- liftEff $ Tm.timeout Config.searchTimeout $ do
  --          E.runEvent (const $ pure unit) (const $ pure unit) $
  --            setQE (ch <> " path:\"" <> p <> "\"")
  --        (toInput $ M.SearchTimeout tim) `E.andThen` \_ -> do
  --          toInput $ M.SearchValidation true

-- TODO: String/Path type again?
handleSearchSubmit :: forall e. Search -> String -> E.Event (FileAppEff e) M.Input
handleSearchSubmit search path = do
  liftEff $ maybe (pure unit) Tm.clearTimeout search.timeout
  setQE (search.nextValue <> " +path:" <> path)

-- ATTENTION
-- This all should be moved to `initializer`
-- ATTENTION
handleShare :: forall e. Mi.Item -> E.Event (FileAppEff e) M.Input
handleShare item = E.async $ Aff.makeAff $ \_ k -> do
  url <- itemURL item
  k $ inj $ M.SetDialog (Just $ ShareDialog url)
  mbCopy <- document globalWindow >>= getElementById "copy-button"
  case mbCopy of
    Nothing -> pure unit
    Just btn -> void do
      Z.make btn >>= Z.onCopy (Z.setData "text/plain" url)

handler :: forall e. M.Request -> E.Event (FileAppEff e) M.Input
handler r =
  case r of
    M.Delete item -> handleDeleteItem item
    M.CreateNotebook state -> handleCreateNotebook state
    M.FileListChanged node state -> handleFileListChanged node state
    M.Move item -> handleMoveItem item
    M.SetSort sort -> handleSetSort sort
    M.Open item -> handleOpenItem item
    M.CreateFolder state -> handleCreateFolder state
    M.UploadFile node _ -> handleUploadFile node
    M.MountDatabase _ -> handleMountDatabase
    M.Configure _ -> handleConfigure
    M.SearchSubmit s p -> handleSearchSubmit s p
    M.SearchClear isSearching search -> handleSearchClear isSearching search
    M.SearchChange search ch p -> handleSearchChange search ch p
    M.Share item -> handleShare item

itemURL :: forall e. Mi.Item -> Eff (dom :: DOM | e) String
itemURL item = do
  loc <- U.locationString
  hash <- Rh.getHash
  let newUrl = loc <> case item.resource of
        Mr.File -> foldl (<>) ""
             [Config.notebookUrl,
              "#", Mi.itemPath item,
              "/view",
              "/?q=", U.encodeURIComponent ("select * from ...")
             ]
        Mr.Notebook -> foldl (<>) ""
             [Config.notebookUrl,
              "#", Mi.itemPath item,
              "/view"]
        _ -> "#" <> Cd.updatePath (item.root <> "/" <> item.name) hash
  pure $ newUrl

setQE :: forall e. String -> E.Event (FileAppEff e) M.Input
setQE q = do
  case S.mkQuery q of
    Left _ | q /= "" -> toInput $ SearchValidation false
    Right _ -> do
      liftEff (Rh.modifyHash $ Cd.updateQ q)
      toInput $ SearchValidation true
    _ -> do
      liftEff (Rh.modifyHash $ Cd.updateQ "")
      toInput $ SearchValidation true

-- open dir or db
moveDown :: forall e. Mi.Item -> Eff (dom :: DOM | e) Unit
moveDown item = Rh.modifyHash $ Cd.updatePath (item.root <> "/" <> item.name <> "/")

-- open notebook or file
open :: forall e. Mi.Item -> Boolean -> Eff (dom :: DOM | e) Unit
open item isNew = U.newTab $ foldl (<>) ""
                  ([Config.notebookUrl,
                    "#", Mi.itemPath item,
                    "/edit"] <>
                     if isNew then
                     ["/?q=", U.encodeURIComponent ("select * from ...")]
                   else [])

-- get fresh name for this state
getNewName :: String -> M.State -> String
getNewName name state =
  if A.findIndex (\x -> x.name == name) state.items /= -1 then
    getNewName' name 1
    else name
  where getNewName' name i =
          -- Str.split and Str.joinWith work with []
          -- converting from/to List will be too expensive
          case Str.split "." name of
            [] -> ""
            body:suffixes ->
              let newName = Str.joinWith "." $ (body <> show i):suffixes
              in if A.findIndex
                    (\x -> x.name == newName)
                    state.items /= -1
                 then getNewName' name (i + 1)
                 else newName

getDirectories :: forall e. String -> E.Event (FileAppEff e) M.Input
getDirectories path = do
  ei <- liftAff $ Aff.attempt $ Api.listing path
  case ei of
    Right items -> do
      let children = A.filter (\x -> x.resource == Mr.Directory ||
                                   x.resource == Mr.Database) items
          directories = (\x -> path <> x.name <> "/") <$> children

      (toInput $ AddRenameDirs directories) `E.andThen` \_ ->
        fold (getDirectories <$> directories)
    _ -> empty

selectThis :: forall e o. Et.Event (|o) ->
              E.EventHandler (E.Event (dom :: DOM|e) M.Input)
selectThis ev =
  pure $ (E.async $ Aff.makeAff \_ _ -> U.select ev.target)

import Debug.Foreign

rename :: forall e. Mi.Item -> String ->
          E.EventHandler (E.Event (FileAppEff e) M.Input)
rename item dest = pure do
  let o = fprintUnsafe dest
      move :: Aff.Aff (FileAppEff e) String
      move = Api.moveItem item dest
  errorString <- liftAff $ move
  (toInput $ RenameError errorString) `E.andThen` \_ -> do
    case errorString of
      "" -> do liftEff U.reload
               empty
      _ -> empty

checkRename :: forall e. String -> RenameDialogRec ->
               E.EventHandler (E.Event (FileAppEff e) M.Input)
checkRename name r = pure do
  if name == ""
    then toInput $ RenameError "Please, enter new name"
    else
    (if Str.indexOf "/" name /= -1
     then toInput $ RenameError "Incorrect File Name"
     else checkList name r.selectedContent) `E.andThen` \_ ->
    toInput $ RenameChanged name

renameItemClicked :: forall e. String -> String ->
                     E.EventHandler (E.Event (FileAppEff e) M.Input)
renameItemClicked target dir = pure $ do
  (toInput $ SetRenameSelected dir) `E.andThen` \_ -> do
    items <- liftAff $ Api.listing dir
    let list = _.name <$> items
    (toInput $ RenameSelectedContent list) `E.andThen` \_ ->
      checkList target list

checkList :: forall e. String -> [String] -> E.Event (FileAppEff e) M.Input
checkList target list =
  toInput case A.elemIndex target list of
    -1 -> RenameError ""
    _ ->  RenameError "Item with such name exists in target folder"

breadcrumbClicked :: forall e. Breadcrumb -> E.Event (FileAppEff e) M.Input
breadcrumbClicked b = do
  liftEff $ Rh.modifyHash $ Cd.updatePath b.link
  empty

-- | File component main handler
module Controller.File
  ( handler
  , getDirectories
  , selectThis
  , rename
  , checkRename
  , renameItemClicked
  , breadcrumbClicked
  ) where

import Control.Apply
import Control.Inject1 (Inject1, inj)
import Control.Monad.Aff.Class
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Random
import Control.Monad.Error.Class
import Control.Monad.Trans
import Control.Plus (empty)
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foldable
import Data.Maybe
import Data.Traversable
import Data.Tuple
import DOM
import EffectTypes
import Input.File.Item (ItemInput(..))
import Input.File.Rename (RenameInput(..))
import Input.File.Search (SearchInput(..))
import Model.DialogResume
import Model.Breadcrumb
import qualified Api.Fs as Api
import qualified Config as Config
import qualified Control.Monad.Aff as Aff
import qualified Control.Timer as Tm
import qualified Control.UI.ZClipboard as Z
import qualified Data.Array as A
import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import qualified Driver.File as Cd
import qualified Halogen as Hl
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.HTML.Events.Types as Et
import qualified Model.File as M
import qualified Model.Item as Mi
import qualified Model.Notebook as Mn
import qualified Model.Resource as Mr
import qualified Network.HTTP.Affjax as Af
import qualified Routing.Hash as Rh
import qualified Text.SlamSearch as S
import qualified Utils as U
import qualified Utils.Event as Ue
import qualified Utils.File as Uf

toInput :: forall m a b. (Applicative m, Inject1 a b) => a -> m b
toInput = pure <<< inj

handler :: forall e. M.Request -> E.Event (FileAppEff e) M.Input
handler r =
  case r of
    M.Delete item -> E.async $ do
      Api.deleteItem item
      toInput $ ItemRemove item

    M.CreateNotebook state -> do
      let name = getNewName Config.newNotebookName state
      path <- liftEff $ Cd.getPath <$> Rh.getHash
      let notebook = Mi.initNotebook{root = path, name = name, phantom = true}
      -- immidiately updating state and then
      (toInput $ ItemAdd notebook) `E.andThen` \_ -> do
        f <- liftAff $ Aff.attempt $ Api.makeNotebook notebook Mn.newNotebook
        (toInput $ ItemRemove notebook) `E.andThen` \_ ->  do
          case f of
            Left _ -> empty
            Right _ -> do
              liftEff $ open notebook{phantom = false} false
              -- and add real notebook to list
              toInput $ ItemAdd notebook{phantom = false}

    M.FileListChanged node state -> do
      fileArr <- Uf.fileListToArray <$> (liftAff $ Uf.files node)
      liftEff $ U.clearValue node
      case A.head fileArr of
        Nothing ->
          let err :: Aff.Aff (FileAppEff e) M.Input
              err = throwError $ error "empty filelist"
          in liftAff err
        Just file -> do
          let newReader :: Eff (FileAppEff e) _
              newReader = Uf.newReaderEff

              readAsBinaryString :: _ -> _ -> Aff.Aff (FileAppEff e) _
              readAsBinaryString = Uf.readAsBinaryString

          path <- liftEff (Cd.getPath <$> Rh.getHash)
          name <- flip getNewName state <$> (liftEff $ Uf.name file)
          let fileItem = Mi.initFile{root = path, name = name, phantom = true}

          reader <- liftEff newReader
          content <- liftAff $ readAsBinaryString file reader

          (toInput $ ItemAdd fileItem) `E.andThen` \_ -> do
            f <- liftAff $ Aff.attempt $ Api.makeFile fileItem content
            (toInput $ ItemRemove fileItem) `E.andThen` \_ -> do
              case f of
                Left _ -> empty
                Right _ -> do
                  liftEff $ open fileItem{phantom = false} false
                  toInput $ ItemAdd fileItem{phantom = false}

    M.Move item -> do
      (toInput $ M.SetDialog (Just (RenameDialog $ initialRenameDialog item)))
        `E.andThen` \_ -> do
        getDirectories "/"

    M.SetSort sort -> do
      liftEff $ Rh.modifyHash $ Cd.updateSort sort
      empty

    -- opens item
    M.Open item -> do
      liftEff $ case item.resource of
        Mr.Directory ->
          moveDown item
        Mr.Database ->
          moveDown item
        Mr.File ->
          open item true
        Mr.Table ->
          open item true
        Mr.Notebook ->
          open item false
      empty

    -- clicked on _Folder_ link, create phantom folder
    M.CreateFolder state -> do
      let name = getNewName Config.newFolderName state
      path <- liftEff (Cd.getPath <$> Rh.getHash)
      toInput $ ItemAdd $ Mi.initDirectory{root = path, name = name}

    -- clicked on _File_ link triggering file uploading
    M.UploadFile node _ -> do
      let el = U.convertToElement node
      mbInput <- liftEff $ querySelector "input" el
      case mbInput of
        Nothing -> empty
        Just input -> do
          liftEff $ Ue.raiseEvent "click" input
          empty

    M.MountDatabase _ ->
      toInput $ M.SetDialog (Just MountDialog)

    M.Configure _ -> do
      toInput $ M.SetDialog (Just ConfigureDialog)

    M.SearchSubmit s p -> do
      liftEff $ maybe (pure unit) Tm.clearTimeout s.timeout
      setQE (s.nextValue <> " +path:" <> p)

    M.SearchClear isSearching search -> do
      liftEff $ maybe (pure unit) Tm.clearTimeout search.timeout
      if isSearching then do
        rnd <- show <$> (liftEff $ randomInt 1000000 2000000)
        liftEff (Rh.modifyHash $ Cd.updateSalt rnd)
        toInput $ M.Loading false
        else
        setQE "path:/"

    M.SearchChange search ch p -> E.async $ Aff.makeAff $ \_ k -> do
      k $ inj $ SearchNextValue ch
      maybe (pure unit) Tm.clearTimeout search.timeout
      tim <- Tm.timeout Config.searchTimeout $ do
        E.runEvent (const $ pure unit) (const $ pure unit) $
          setQE (ch <> " path:\"" <> p <> "\"")
      k $ inj $ SearchTimeout tim
      k $ inj $ SearchValidation true

    -- ATTENTION
    -- This works too slow
    --      (toInput $ M.SearchNextValue ch) `E.andThen` \_ -> do
    --        tim <- liftEff $ Tm.timeout Config.searchTimeout $ do
    --          E.runEvent (const $ pure unit) (const $ pure unit) $
    --            setQE (ch <> " path:\"" <> p <> "\"")
    --        (toInput $ M.SearchTimeout tim) `E.andThen` \_ -> do
    --          toInput $ M.SearchValidation true

    -- ATTENTION
    -- This all should be moved to `initializer`
    -- ATTENTION
    M.Share item -> E.async $ Aff.makeAff $ \_ k -> do
      url <- itemURL item
      k $ inj $ M.SetDialog (Just $ ShareDialog url)
      mbCopy <- document globalWindow >>= getElementById "copy-button"
      case mbCopy of
        Nothing -> pure unit
        Just btn -> void do
          Z.make btn >>= Z.onCopy (Z.setData "text/plain" url)

  where

  itemURL :: forall e. Mi.Item -> Eff _ String
  itemURL item = do
    loc <- U.locationString
    hash <- Rh.getHash
    let newUrl = loc <> case item.resource of
          Mr.File -> foldl (<>) ""
               [Config.notebookUrl,
                "#", Mi.itemPath item,
                "/view",
                "/?q=", U.encodeURIComponent ("select * from ...")
               ]
          Mr.Notebook -> foldl (<>) ""
               [Config.notebookUrl,
                "#", Mi.itemPath item,
                "/view"]
          _ -> "#" <> Cd.updatePath (item.root <> "/" <> item.name) hash
    pure $ newUrl

  setQE :: String -> E.Event (FileAppEff e) M.Input
  setQE q = do
    case S.mkQuery q of
      Left _ | q /= "" -> toInput $ SearchValidation false
      Right _ -> do
        liftEff (Rh.modifyHash $ Cd.updateQ q)
        toInput $ SearchValidation true
      _ -> do
        liftEff (Rh.modifyHash $ Cd.updateQ "")
        toInput $ SearchValidation true

  -- open dir or db
  moveDown :: Mi.Item -> Eff _ Unit
  moveDown item = Rh.modifyHash $ Cd.updatePath (item.root <> "/" <> item.name <> "/")

  -- open notebook or file
  open :: Mi.Item -> Boolean -> Eff _ Unit
  open item isNew = U.newTab $ foldl (<>) ""
                    ([Config.notebookUrl,
                      "#", Mi.itemPath item,
                      "/edit"] <>
                       if isNew then
                       ["/?q=", U.encodeURIComponent ("select * from ...")]
                     else [])

  -- get fresh name for this state
  getNewName :: String -> M.State -> String
  getNewName name state =
    if A.findIndex (\x -> x.name == name) state.items /= -1 then
      getNewName' name 1
      else name
    where getNewName' name i =
            -- Str.split and Str.joinWith work with []
            -- converting from/to List will be too expensive
            case Str.split "." name of
              [] -> ""
              body:suffixes ->
                let newName = Str.joinWith "." $ (body <> show i):suffixes
                in if A.findIndex
                      (\x -> x.name == newName)
                      state.items /= -1
                   then getNewName' name (i + 1)
                   else newName

getDirectories :: forall e. String -> E.Event (FileAppEff e) M.Input
getDirectories path = do
  ei <- liftAff $ Aff.attempt $ Api.listing path
  case ei of
    Right items -> do
      let children = A.filter (\x -> x.resource == Mr.Directory ||
                                   x.resource == Mr.Database) items
          directories = (\x -> path <> x.name <> "/") <$> children

      (toInput $ AddRenameDirs directories) `E.andThen` \_ ->
        fold (getDirectories <$> directories)
    _ -> empty

selectThis :: forall e o. Et.Event (|o) ->
              E.EventHandler (E.Event (dom :: DOM|e) M.Input)
selectThis ev =
  pure $ (E.async $ Aff.makeAff \_ _ -> U.select ev.target)

import Debug.Foreign

rename :: forall e. Mi.Item -> String ->
          E.EventHandler (E.Event (FileAppEff e) M.Input)
rename item dest = pure do
  let o = fprintUnsafe dest
      move :: Aff.Aff (FileAppEff e) String
      move = Api.moveItem item dest
  errorString <- liftAff $ move
  (toInput $ RenameError errorString) `E.andThen` \_ -> do
    case errorString of
      "" -> do liftEff U.reload
               empty
      _ -> empty

checkRename :: forall e. String -> RenameDialogRec ->
               E.EventHandler (E.Event (FileAppEff e) M.Input)
checkRename name r = pure do
  if name == ""
    then toInput $ RenameError "Please, enter new name"
    else
    (if Str.indexOf "/" name /= -1
     then toInput $ RenameError "Incorrect File Name"
     else checkList name r.selectedContent) `E.andThen` \_ ->
    toInput $ RenameChanged name

renameItemClicked :: forall e. String -> String ->
                     E.EventHandler (E.Event (FileAppEff e) M.Input)
renameItemClicked target dir = pure $ do
  (toInput $ SetRenameSelected dir) `E.andThen` \_ -> do
    items <- liftAff $ Api.listing dir
    let list = _.name <$> items
    (toInput $ RenameSelectedContent list) `E.andThen` \_ ->
      checkList target list

checkList :: forall e. String -> [String] -> E.Event (FileAppEff e) M.Input
checkList target list =
  toInput case A.elemIndex target list of
    -1 -> RenameError ""
    _ ->  RenameError "Item with such name exists in target folder"

breadcrumbClicked :: forall e. Breadcrumb -> E.Event (FileAppEff e) M.Input
breadcrumbClicked b = do
  liftEff $ Rh.modifyHash $ Cd.updatePath b.link
  empty


Better Go identifier normalization

Better Go identifier normalization

Original commit 9da982531d30a8f3efa2ea68b9f2a1ef5ea86b2e

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Just $ simpleNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = goNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeCharacters :: String -> String
legalizeCharacters str =
    Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str

startWithLetter :: String -> String
startWithLetter str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            str
        else
            "The" <> str

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderUnionToGolang :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- renderTypeToGolang x
        pure
            if isValueType x then
                { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
            else
                { rendered, comment: Nothing }
    Nothing -> do
        noComment =<< lookupUnionName s

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang $ unionToSet types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

goNameStyle :: String -> String
goNameStyle = legalizeCharacters >>> camelCase >>> capitalize >>> startWithLetter

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    forTopLevel_ \topLevelName topLevelType -> do
        { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
        blank
        line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
        blank
        line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
        line $ "    var r " <> topLevelName
        line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
        line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
        indent do
            line "return json.Marshal(r)"
        line "}"
    blank
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""
    for_ unions \types -> do
        blank
        renderGolangUnion types

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: Int -> IRClassData -> Doc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let { names: propertyNames } = transformNames (simpleNamer goNameStyle) ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ M.keys properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> Doc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    fields <- L.fromFoldable nonNullTypes # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name _ -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name rendered
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Just $ simpleNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = goNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("F_" <> str)

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderUnionToGolang :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- renderTypeToGolang x
        pure
            if isValueType x then
                { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
            else
                { rendered, comment: Nothing }
    Nothing -> do
        noComment =<< lookupUnionName s

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang $ unionToSet types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

goNameStyle :: String -> String
goNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    forTopLevel_ \topLevelName topLevelType -> do
        { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
        blank
        line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
        blank
        line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
        line $ "    var r " <> topLevelName
        line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
        line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
        indent do
            line "return json.Marshal(r)"
        line "}"
    blank
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""
    for_ unions \types -> do
        blank
        renderGolangUnion types

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: Int -> IRClassData -> Doc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let { names: propertyNames } = transformNames (simpleNamer goNameStyle) ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ M.keys properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> Doc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    fields <- L.fromFoldable nonNullTypes # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name _ -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name rendered
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p