[IMPROVEMENT] Resolved unused warning

[IMPROVEMENT] Resolved unused warning

Removing unused variable x to resolve warning in the build

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

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 x -> 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


Fix #340 by pruning form fields with changed value types

Thanks @garyb for the tip.

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Numeric s) = quoteStringNumeric s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    quoteStringNumeric s | isSQLNum s = s
                         | otherwise = quoteString s
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit
      SP.eof

slamDownFields :: SlamDown -> Array (Tuple String FormField)
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let prunedSM = foldl (flip SM.delete) s $ keysToPrune s s'
                    mergedSM = prunedSM `SM.union` s'
                in SlamDownState mergedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

  where
    formFieldValueType :: FormFieldValue -> Maybe TextBoxType
    formFieldValueType (SingleValue ty _) = Just ty
    formFieldValueType _ = Nothing

    formFieldValueTypeChanged :: FormFieldValue -> FormFieldValue -> Boolean
    formFieldValueTypeChanged old new = formFieldValueType old /= formFieldValueType new

    -- | Returns the keys that are either not present in the new state, or have had their types changed.
    keysToPrune :: SM.StrMap _ -> SM.StrMap _ -> Array _
    keysToPrune oldState newState =
      SM.foldMap
        (\key oldVal ->
          case SM.lookup key newState of
            Nothing -> [key]
            Just newVal ->
              if formFieldValueTypeChanged oldVal newVal then
                [key]
              else
                []
        )
        oldState

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Numeric s) = quoteStringNumeric s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    quoteStringNumeric s | isSQLNum s = s
                         | otherwise = quoteString s
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit
      SP.eof

slamDownFields :: SlamDown -> Array (Tuple String FormField)
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let removedKeys = SM.keys s \\ SM.keys s'
                    mergedSM = s `SM.union` s'
                    prunedSM = foldl (\f k -> SM.delete k f) mergedSM removedKeys
                in SlamDownState prunedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))


Remove unnecessary wrapper module

Remove unnecessary wrapper module

module Docopt.Spec.Parser where

import qualified Docopt.Spec.Parser.Options as Options
import qualified Docopt.Spec.Parser.Usage   as Usage


redefined IndentParser to use IndexingT

redefined IndentParser to use IndexingT

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (State, StateT, runState, runStateT, get, put, modify, lift)

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

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , compileADTDef
  , Associativity(..)
  , DataConstr(..)
  , Type(..)
  , Meta(..))
import AST as AST
import IndentParser (block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

type IndexingT m a = StateT Int m a

runIndexingT :: forall m a. (Monad m) => IndexingT m a -> m (Tuple a Int)
runIndexingT action = runStateT action 0

type IndentParser s a = IndexingT (ParserT s (State Position)) a

fresh :: forall m. (Monad m) => IndexingT m Int
fresh = do
  i <- get
  modify (\i -> i + 1)
  pure i

freshMeta :: forall m. (Monad m) => IndexingT m Meta
freshMeta = AST.idxMeta <$> fresh

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

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

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

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

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p <* skipWhite

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

-- returns the next non whitespace character
lookAhead :: forall m. (Monad m) => ParserT String m Char
lookAhead = PC.lookAhead $ whiteSpace *> anyChar

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

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~'
  ,'°']

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

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

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

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

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

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

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

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

-- | Parser for type names
upperCaseName :: forall m. (Monad m) => ParserT String m String
upperCaseName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

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

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

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

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

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

-- | Parser for data constructors
constructor :: forall m. (Monad m) => ParserT String m Atom
constructor = Constr <$> upperCaseName

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

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

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

infixFunc :: forall m. (Monad m) => ParserT String m String
infixFunc = char '`' *> name <* char '`'

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)
  where
    infixTable :: OperatorTable m String TypeTree
    infixTable =
      (\x ->
        (uncurry3
          (\p op assoc ->
            Infix (do
                  meta <- freshMeta
                  Binary freshMeta <<< toOpTuple <<< op <$> spaced p) assoc))
        <$> x)
      <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          meta <- freshMeta
          pure $ \e -> case e of
            Atom _ (AInt ai) -> Atom meta (AInt (-ai))
            _                -> Unary meta (toOpTuple Sub) e

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

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = PC.choice $ (\x -> (uncurry3 (\p op _ -> op <$> p)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators

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

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

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> do
      meta <- freshMeta
      pure $ App meta e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  meta <- freshMeta
  pure $ IfExpr meta testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> do
      meta <- freshMeta
      pure $ NTuple meta (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing -> do
      meta <- freshMeta
      case me2 of
        Nothing -> pure $ PrefixOp meta op
        Just e2 -> pure $ SectR meta op e2
    Just e1 ->
      case me2 of
        Nothing -> do
          meta <- freshMeta
          pure $ SectL meta e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  meta <- freshMeta
  pure $ List meta exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  meta <- freshMeta
  pure $ ArithmSeq meta start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  meta <- freshMeta
  pure $ ListComp meta start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          meta <- freshMeta
          pure $ Let meta b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          meta <- freshMeta
          pure $ Gen meta b e
        parseGuard = do
          meta <- freshMeta
          expr' <- ilexe expr
          pure $ Guard meta expr'

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  meta1 <- freshMeta
  meta2 <- freshMeta
  pure (List meta1 ((Atom meta2 <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  meta <- freshMeta
  pure $ Lambda meta binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  meta <- freshMeta
  pure $ LetExpr meta binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding Meta) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding Meta) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

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

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError (Tuple a Int)
runParserIndent p src = fst $ flip runState initialPos $ runParserT src $ runIndexingT p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------
-- Grammar
----------
{-
<BINDING>
  ::= <SIMPLE>
    | `[` <LIST> `]`
    | `(` <LIST> `)`

<SIMPLE>
  ::= <LIT>

<LIST>
  ::= <CONSES> { `,` <CONSES> }

<CONSES>
  ::= <INFIXES> { `:` <INFIXES> }

<INFIXES>
  ::= { <COMPLEX> <INF_CONSTR> } <COMPLEX>

<COMPLEX>
  ::= <CONSTR> { <BINDING> }
    | <BINDING>
-}

binding :: IndentParser String (Binding Meta)
binding = do
  whiteSpace
  fix $ \bnd -> do
    la <- lookAhead
    case la of
         '(' -> do
            cs <- ilexe (char '(') *> indent (bndList bnd) <* indent (char ')')
            case cs of
                 Nil        -> NTupleLit <$> freshMeta <*> pure Nil
                 Cons c Nil -> pure c
                 cs'        -> NTupleLit <$> freshMeta <*> pure cs'
         '[' -> do
            cs <- ilexe (char '[') *> indent (bndList bnd) <* indent (char ']')
            case cs of
                 Nil        -> ListLit <$> freshMeta <*> pure Nil
                 cs'        -> ListLit <$> freshMeta <*> pure cs'
         _   -> PC.try $ ilexe bndSimple

bndSimple :: IndentParser String (Binding Meta)
bndSimple = PC.try bndLit

bndLit :: forall m. (Monad m) => ParserT String m (Binding Meta)
bndLit = Lit <$> freshMeta <*> atom

bndList :: IndentParser String (Binding Meta) -> IndentParser String (List (Binding Meta))
bndList bnd = PC.sepBy
  (PC.try <<< indent <<< bndConses $ bnd)
  (PC.try <<< indent <<< char $ ',')

bndConses :: FixedIndentParser String (Binding Meta)
bndConses bnd = PC.chainr1
  (PC.try <<< ilexe <<< bndInfixes $ bnd)
  (do PC.try <<< indent <<< char $ ':'
      ConsLit <$> freshMeta)

bndInfixes :: FixedIndentParser String (Binding Meta)
bndInfixes bnd = PC.chainl1
  (PC.try (ilexe ((bndComplex bnd))))
  (do o <- PC.try (indent infixConstructor)
      meta <- freshMeta
      pure (\l r -> ConstrLit meta (InfixDataConstr o LEFTASSOC 9 l r)))

bndComplex :: FixedIndentParser String (Binding Meta)
bndComplex bnd =
  PC.try
    (do n  <- ilexe upperCaseName
        as <- many1 bnd
        meta <- freshMeta
        pure $ ConstrLit meta (PrefixDataConstr n (length as) as))
  <|> indent bnd

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

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

typeDefinition' :: IndentParser String (List Definition)
typeDefinition' = compileADTDef <$> typeDefinition

-- TODO: Infix function definition

definitions :: IndentParser String (List Definition)
definitions = do
  skipWhite
  defs <- many $ (PC.try typeDefinition') <|> (pure <$> definition)
  pure $ concat defs

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
-- Grammar
----------
{-
<TYPE>
  ::= <TYPE1> [ `->` <TYPE> ]

<TYPE1>
  ::= <SIMPLE>
    | `[` <TYPE> `]`
    | `(` <TYPE> { `,` <TYPE> } `)`
    | <CONS> { <TYPE> }

<SIMPLE>
  ::= `Int` | `Bool` | `Char` | <TYPEVAR>
-}

type1 :: FixedIndentParser String Type
type1 t = do
  la <- lookAhead
  case la of
       '(' -> do
          ts <- PC.between
            (PC.try <<< ilexe <<< char $ '(')
            (PC.try <<< indent <<< char $ ')')
            (indent t `PC.sepBy1` (PC.try <<< indent <<< char) ',')
          case ts of
               Nil         -> fail "Empty Tuple"
               Cons t' Nil -> pure t'
               ts'         -> (pure <<< TTuple) ts'
       '[' -> PC.between
          (PC.try <<< ilexe <<< char $ '[')
          (PC.try <<< indent <<< char $ ']')
          (TList <$> indent t)
       _ -> (PC.try <<< indent) simpleType <|> (indent <<< typeCons) t

simpleType :: IndentParser String Type
simpleType = do
  la <- lookAhead
  case la of
       'B' -> TypCon <$> string "Bool"
       'I' -> TypCon <$> string "Int"
       'C' -> TypCon <$> string "Char"
       _   -> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe upperCaseName
  ps <- many <<< indent $ types1 t <|> simpleType
  pure $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (PC.try <<< indent <<< char $ '(')
  (PC.try <<< indent <<< char $ ')')
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> (indent <<< type1) t `PC.chainr1` ((indent <<< string) "->" *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe <<< char $ '(')
  (PC.try <<< indent <<< char $ ')')
  (do ts <- indent t `PC.sepBy1` (PC.try <<< indent <<< char) ','
      case ts of
           Nil        -> fail "Empty Tuple"
           Cons x Nil -> pure x
           xs         -> (pure <<< TTuple) xs)

types1 :: IndentParser String Type -> IndentParser String Type
types1 t = do
  la <- lookAhead
  case la of
       '[' -> TList <$> ((ilexe <<< char) '[' *> indent t <* (indent <<< char) ']')
       '(' -> PC.try (typeExpr t) <|> typeTuple t
       _   -> PC.try simpleType <|> typeCons t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------
-- Grammar
----------
{-
<TYPEDEFINITION>
  ::= 'data' <UCASENAME> { <NAME> } [ '=' <CONSTR> { '|' <CONSTR> } ]

<CONSTR>
  ::= <PREFIXCONSTR>
    | <INFIXCONSTR>

<PREFIXCONSTR>
  ::= <UCASENAME> { <TYPE> }
    | <TYPE> <CONSTROP> <TYPE>

<CONSTROP>
  ::= ':' <SYMBOL> { <SYMBOL> }       (* at least one symbol after ':' is needed,
                                       * to no confuse it with a list-(:).
                                       *)
-}

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent upperCaseName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataConstr Type)
dataConstructorDefinition
  = PC.try prefixDataConstrtructorDefinition
  <|> infixDataConstrtructorDefinition

prefixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
prefixDataConstrtructorDefinition = do
  n <- ilexe upperCaseName
  ps <- many types
  pure $ PrefixDataConstr n (length ps) ps

infixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
infixDataConstrtructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixDataConstr o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many1 symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (runState, runStateT, StateT, get, put, modify, lift)

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

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , compileADTDef
  , Associativity(..)
  , DataConstr(..)
  , Type(..)
  , Meta(..))
import AST as AST
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

type IndexingT m a = StateT Int m a

fresh :: forall m. (Monad m) => IndexingT m Int
fresh = do
  i <- get
  modify (\i -> i + 1)
  pure i

freshMeta :: forall m. (Monad m) => IndexingT m Meta
freshMeta = AST.idxMeta <$> fresh

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

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

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

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

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p <* skipWhite

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

-- returns the next non whitespace character
lookAhead :: forall m. (Monad m) => ParserT String m Char
lookAhead = PC.lookAhead $ whiteSpace *> anyChar

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

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~'
  ,'°']

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

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

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

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

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

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

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

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

-- | Parser for type names
upperCaseName :: forall m. (Monad m) => ParserT String m String
upperCaseName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

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

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

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

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

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

-- | Parser for data constructors
constructor :: forall m. (Monad m) => ParserT String m Atom
constructor = Constr <$> upperCaseName

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

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

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

infixFunc :: forall m. (Monad m) => ParserT String m String
infixFunc = char '`' *> name <* char '`'

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)
  where
    infixTable :: OperatorTable m String TypeTree
    infixTable =
      (\x ->
        (uncurry3
          (\p op assoc ->
            Infix (do
                  meta <- freshMeta
                  Binary freshMeta <<< toOpTuple <<< op <$> spaced p) assoc))
        <$> x)
      <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          meta <- freshMeta
          pure $ \e -> case e of
            Atom _ (AInt ai) -> Atom meta (AInt (-ai))
            _                -> Unary meta (toOpTuple Sub) e

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

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = PC.choice $ (\x -> (uncurry3 (\p op _ -> op <$> p)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators

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

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

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> do
      meta <- freshMeta
      pure $ App meta e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  meta <- freshMeta
  pure $ IfExpr meta testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> do
      meta <- freshMeta
      pure $ NTuple meta (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing -> do
      meta <- freshMeta
      case me2 of
        Nothing -> pure $ PrefixOp meta op
        Just e2 -> pure $ SectR meta op e2
    Just e1 ->
      case me2 of
        Nothing -> do
          meta <- freshMeta
          pure $ SectL meta e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  meta <- freshMeta
  pure $ List meta exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  meta <- freshMeta
  pure $ ArithmSeq meta start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  meta <- freshMeta
  pure $ ListComp meta start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          meta <- freshMeta
          pure $ Let meta b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          meta <- freshMeta
          pure $ Gen meta b e
        parseGuard = do
          meta <- freshMeta
          expr' <- ilexe expr
          pure $ Guard meta expr'

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  meta1 <- freshMeta
  meta2 <- freshMeta
  pure (List meta1 ((Atom meta2 <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  meta <- freshMeta
  pure $ Lambda meta binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  meta <- freshMeta
  pure $ LetExpr meta binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding Meta) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding Meta) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

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

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT src p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------
-- Grammar
----------
{-
<BINDING>
  ::= <SIMPLE>
    | `[` <LIST> `]`
    | `(` <LIST> `)`

<SIMPLE>
  ::= <LIT>

<LIST>
  ::= <CONSES> { `,` <CONSES> }

<CONSES>
  ::= <INFIXES> { `:` <INFIXES> }

<INFIXES>
  ::= { <COMPLEX> <INF_CONSTR> } <COMPLEX>

<COMPLEX>
  ::= <CONSTR> { <BINDING> }
    | <BINDING>
-}

binding :: IndentParser String (Binding Meta)
binding = do
  whiteSpace
  fix $ \bnd -> do
    la <- lookAhead
    case la of
         '(' -> do
            cs <- ilexe (char '(') *> indent (bndList bnd) <* indent (char ')')
            case cs of
                 Nil        -> NTupleLit <$> freshMeta <*> pure Nil
                 Cons c Nil -> pure c
                 cs'        -> NTupleLit <$> freshMeta <*> pure cs'
         '[' -> do
            cs <- ilexe (char '[') *> indent (bndList bnd) <* indent (char ']')
            case cs of
                 Nil        -> ListLit <$> freshMeta <*> pure Nil
                 cs'        -> ListLit <$> freshMeta <*> pure cs'
         _   -> PC.try $ ilexe bndSimple

bndSimple :: IndentParser String (Binding Meta)
bndSimple = PC.try bndLit

bndLit :: forall m. (Monad m) => ParserT String m (Binding Meta)
bndLit = Lit <$> freshMeta <*> atom

bndList :: IndentParser String (Binding Meta) -> IndentParser String (List (Binding Meta))
bndList bnd = PC.sepBy
  (PC.try <<< indent <<< bndConses $ bnd)
  (PC.try <<< indent <<< char $ ',')

bndConses :: FixedIndentParser String (Binding Meta)
bndConses bnd = PC.chainr1
  (PC.try <<< ilexe <<< bndInfixes $ bnd)
  (do PC.try <<< indent <<< char $ ':'
      ConsLit <$> freshMeta)

bndInfixes :: FixedIndentParser String (Binding Meta)
bndInfixes bnd = PC.chainl1
  (PC.try (ilexe ((bndComplex bnd))))
  (do o <- PC.try (indent infixConstructor)
      meta <- freshMeta
      pure (\l r -> ConstrLit meta (InfixDataConstr o LEFTASSOC 9 l r)))

bndComplex :: FixedIndentParser String (Binding Meta)
bndComplex bnd =
  PC.try
    (do n  <- ilexe upperCaseName
        as <- many1 bnd
        meta <- freshMeta
        pure $ ConstrLit meta (PrefixDataConstr n (length as) as))
  <|> indent bnd

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

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

typeDefinition' :: IndentParser String (List Definition)
typeDefinition' = compileADTDef <$> typeDefinition

-- TODO: Infix function definition

definitions :: IndentParser String (List Definition)
definitions = do
  skipWhite
  defs <- many $ (PC.try typeDefinition') <|> (pure <$> definition)
  pure $ concat defs

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
-- Grammar
----------
{-
<TYPE>
  ::= <TYPE1> [ `->` <TYPE> ]

<TYPE1>
  ::= <SIMPLE>
    | `[` <TYPE> `]`
    | `(` <TYPE> { `,` <TYPE> } `)`
    | <CONS> { <TYPE> }

<SIMPLE>
  ::= `Int` | `Bool` | `Char` | <TYPEVAR>
-}

type1 :: FixedIndentParser String Type
type1 t = do
  la <- lookAhead
  case la of
       '(' -> do
          ts <- PC.between
            (PC.try <<< ilexe <<< char $ '(')
            (PC.try <<< indent <<< char $ ')')
            (indent t `PC.sepBy1` (PC.try <<< indent <<< char) ',')
          case ts of
               Nil         -> fail "Empty Tuple"
               Cons t' Nil -> pure t'
               ts'         -> (pure <<< TTuple) ts'
       '[' -> PC.between
          (PC.try <<< ilexe <<< char $ '[')
          (PC.try <<< indent <<< char $ ']')
          (TList <$> indent t)
       _ -> (PC.try <<< indent) simpleType <|> (indent <<< typeCons) t

simpleType :: IndentParser String Type
simpleType = do
  la <- lookAhead
  case la of
       'B' -> TypCon <$> string "Bool"
       'I' -> TypCon <$> string "Int"
       'C' -> TypCon <$> string "Char"
       _   -> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe upperCaseName
  ps <- many <<< indent $ types1 t <|> simpleType
  pure $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (PC.try <<< indent <<< char $ '(')
  (PC.try <<< indent <<< char $ ')')
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> (indent <<< type1) t `PC.chainr1` ((indent <<< string) "->" *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe <<< char $ '(')
  (PC.try <<< indent <<< char $ ')')
  (do ts <- indent t `PC.sepBy1` (PC.try <<< indent <<< char) ','
      case ts of
           Nil        -> fail "Empty Tuple"
           Cons x Nil -> pure x
           xs         -> (pure <<< TTuple) xs)

types1 :: IndentParser String Type -> IndentParser String Type
types1 t = do
  la <- lookAhead
  case la of
       '[' -> TList <$> ((ilexe <<< char) '[' *> indent t <* (indent <<< char) ']')
       '(' -> PC.try (typeExpr t) <|> typeTuple t
       _   -> PC.try simpleType <|> typeCons t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------
-- Grammar
----------
{-
<TYPEDEFINITION>
  ::= 'data' <UCASENAME> { <NAME> } [ '=' <CONSTR> { '|' <CONSTR> } ]

<CONSTR>
  ::= <PREFIXCONSTR>
    | <INFIXCONSTR>

<PREFIXCONSTR>
  ::= <UCASENAME> { <TYPE> }
    | <TYPE> <CONSTROP> <TYPE>

<CONSTROP>
  ::= ':' <SYMBOL> { <SYMBOL> }       (* at least one symbol after ':' is needed,
                                       * to no confuse it with a list-(:).
                                       *)
-}

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent upperCaseName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataConstr Type)
dataConstructorDefinition
  = PC.try prefixDataConstrtructorDefinition
  <|> infixDataConstrtructorDefinition

prefixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
prefixDataConstrtructorDefinition = do
  n <- ilexe upperCaseName
  ps <- many types
  pure $ PrefixDataConstr n (length ps) ps

infixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
infixDataConstrtructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixDataConstr o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many1 symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms