Add `As/IsForeign` instance for solved layouts

module Neodoc.Data.SolvedLayout where

import Prelude
import Data.Either (Either(..))
import Data.Pretty (class Pretty, pretty)
import Data.Maybe (Maybe(..), maybe)
import Data.Bifunctor (lmap)
import Data.Tuple.Nested ((/\))
import Data.Foldable (intercalate, all)
import Data.String as String
import Data.List (List)
import Data.String (singleton) as String
import Data.NonEmpty (NonEmpty)
import Data.Foreign as F
import Data.Foreign.Class as F
import Data.Foreign.Index as F
import Data.Foreign.Index ((!))
import Data.Foreign.Class
import Data.Foreign.Extra as F
import Neodoc.Data.Layout
import Neodoc.OptionAlias
import Neodoc.ArgKey (ArgKey(..))
import Neodoc.ArgKey.Class (class ToArgKey)
import Neodoc.Data.OptionArgument
import Data.Function (on)

-- This type can be specialized for elements of a usage section
type SolvedLayout = Layout SolvedLayoutArg
data SolvedLayoutArg
  = Command     String Boolean
  | Positional  String Boolean
  | Option      OptionAlias (Maybe OptionArgument) Boolean
  | EOA
  | Stdin

instance toArgKeySolvedLayoutArg :: ToArgKey SolvedLayoutArg where
  toArgKey (Command     n   _) = CommandKey n
  toArgKey (Positional  n   _) = PositionalKey n
  toArgKey (Option      a _ _) = OptionKey a
  toArgKey (EOA              ) = EOAKey
  toArgKey (Stdin            ) = StdinKey

instance eqSolvedLayoutArg :: Eq SolvedLayoutArg where
  eq (Command n r) (Command n' r') = n == n' && r == r'
  eq (Positional n r) (Positional n' r') = n == n' && r == r'
  eq (Option n mA r) (Option n' mA' r') = n == n' && mA == mA' && r == r'
  eq EOA EOA = true
  eq Stdin Stdin = true
  eq _ _ = false

instance showSolvedLayoutArg :: Show SolvedLayoutArg where
  show (Command n r) = "Command " <> show n <> " " <> show r
  show (Positional n r) = "Positional " <> show n <> " " <> show r
  show EOA = "EOA"
  show Stdin = "Stdin"
  show (Option n mA r) = "Option " <> show n <> " " <> show mA <> " " <> show r

instance ordSolvedLayoutArg :: Ord SolvedLayoutArg where
  compare (Command n r) (Command n' r') = compare (n /\ r) (n' /\ r')
  compare (Positional n r) (Positional n' r') = compare (n /\ r) (n' /\ r')
  compare (Option n mA r) (Option n' mA' r') = compare (n /\ mA /\ r) (n' /\ mA' /\ r')
  compare EOA EOA = EQ
  compare Stdin Stdin = EQ

  -- the following table must be carefully updated:

  -- by Command
  compare (Command _ _) (Positional _ _) = GT
  compare (Command _ _) (Option _ _ _)   = GT
  compare (Command _ _) EOA              = GT
  compare (Command _ _) Stdin            = GT
  compare (Positional _ _) (Command _ _) = LT
  compare (Option _ _ _)   (Command _ _) = LT
  compare EOA              (Command _ _) = LT
  compare Stdin            (Command _ _) = LT

  compare (Positional _ _) (Option _ _ _) = GT
  compare (Positional _ _) EOA            = GT
  compare (Positional _ _) Stdin          = GT
  compare (Option _ _ _) (Positional _ _) = LT
  compare EOA            (Positional _ _) = LT
  compare Stdin          (Positional _ _) = LT

  compare (Option _ _ _) EOA   = GT
  compare (Option _ _ _) Stdin = GT
  compare EOA   (Option _ _ _) = LT
  compare Stdin (Option _ _ _) = LT

  compare EOA Stdin = GT
  compare Stdin EOA = LT

instance prettySolvedLayoutArg :: Pretty SolvedLayoutArg where
  pretty = go
    where
    go (Command n r) = n <> rep r
    go (Positional n r) = n <> rep r
    go EOA = "--"
    go Stdin = "-"
    go (Option n mA r) = pretty n <> maybe "" pretty mA <> rep r
    rep r = if r then "..." else ""

instance asForeignSolvedLayoutArg :: AsForeign SolvedLayoutArg where
  write (Command n r) = F.toForeign {
      type: "Command"
    , name: F.write n
    , repeatable: F.write r
    }
  write (Positional n r) = F.toForeign {
      type: "Positional"
    , name: F.write n
    , repeatable: F.write r
    }
  write (Option n mArg r) = F.toForeign {
      type: "Option"
    , name: F.write n
    , argument: maybe F.undefined F.write mArg
    , repeatable: F.write r
    }
  write Stdin = F.toForeign { type: "Stdin" }
  write EOA = F.toForeign { type: "EOA" }

instance isForeignSolvedLayoutArg :: IsForeign SolvedLayoutArg where
  read v = do
    typ :: String <- String.toUpper <$> F.readProp "type" v

    case typ of
      "EOA" -> pure EOA
      "STDIN" -> pure Stdin
      "COMMAND" ->
        Command
          <$> F.readProp "name"       v
          <*> F.readProp "repeatable" v
      "POSITIONAL" ->
        Positional
          <$> F.readProp "name"       v
          <*> F.readProp "repeatable" v
      "OPTION" ->
        Option
          <$> F.readProp "name" v
          <*> F.readPropMaybe "argument" v
          <*> F.readProp "repeatable" v
      _ -> Left $ F.errorAt "type" (F.JSONError $ "unknown type: " <> typ)

isRepeatable :: SolvedLayout -> Boolean
isRepeatable (Group           _ r _) = r
isRepeatable (Elem (Command    _ r)) = r
isRepeatable (Elem (Positional _ r)) = r
isRepeatable (Elem (Option   _ _ r)) = r
isRepeatable _ = false

setRepeatable :: Boolean -> SolvedLayout -> SolvedLayout
setRepeatable r (Group           o _ xs) = Group o r xs
setRepeatable r (Elem (Command     n _)) = Elem (Command n r)
setRepeatable r (Elem (Positional  n _)) = Elem (Positional n r)
setRepeatable r (Elem (Option   a mA _)) = Elem (Option a mA r)
setRepeatable _ x = x

setRepeatableOr :: Boolean -> SolvedLayout -> SolvedLayout
setRepeatableOr r (Group           o r' xs) = Group o (r || r') xs
setRepeatableOr r (Elem (Command     n r')) = Elem (Command n (r || r'))
setRepeatableOr r (Elem (Positional  n r')) = Elem (Positional n (r || r'))
setRepeatableOr r (Elem (Option   a mA r')) = Elem (Option a mA (r || r'))
setRepeatableOr _ x = x

isOptional :: SolvedLayout -> Boolean
isOptional (Group o _ _) = o
isOptional _ = false

isPositional :: SolvedLayoutArg -> Boolean
isPositional (Positional _ _) = true
isPositional _ = false

isCommand :: SolvedLayoutArg -> Boolean
isCommand (Command _ _) = true
isCommand _ = false

isOption :: SolvedLayoutArg -> Boolean
isOption (Option _ _ _) = true
isOption _ = false

isFlag :: SolvedLayoutArg -> Boolean
isFlag (Option _ Nothing _) = true
isFlag _ = false

isGroup :: SolvedLayout -> Boolean
isGroup (Group _ _ _) = true
isGroup _ = false

-- Is this layout considered "free"?
isFreeLayout :: SolvedLayout -> Boolean
isFreeLayout (Elem (Option _ _ _)) = true
isFreeLayout (Elem _) = false
isFreeLayout (Group _ _ xs) = all (all isFreeLayout) xs

module Neodoc.Data.SolvedLayout where

import Prelude
import Data.Pretty (class Pretty, pretty)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple.Nested ((/\))
import Data.Foldable (intercalate, all)
import Data.String as String
import Data.List (List)
import Data.String (singleton) as String
import Data.NonEmpty (NonEmpty)
import Neodoc.Data.Layout
import Neodoc.OptionAlias
import Neodoc.ArgKey (ArgKey(..))
import Neodoc.ArgKey.Class (class ToArgKey)
import Neodoc.Data.OptionArgument
import Data.Function (on)

-- This type can be specialized for elements of a usage section
type SolvedLayout = Layout SolvedLayoutArg
data SolvedLayoutArg
  = Command     String Boolean
  | Positional  String Boolean
  | Option      OptionAlias (Maybe OptionArgument) Boolean
  | EOA
  | Stdin

instance toArgKeySolvedLayoutArg :: ToArgKey SolvedLayoutArg where
  toArgKey (Command     n   _) = CommandKey n
  toArgKey (Positional  n   _) = PositionalKey n
  toArgKey (Option      a _ _) = OptionKey a
  toArgKey (EOA              ) = EOAKey
  toArgKey (Stdin            ) = StdinKey

instance eqSolvedLayoutArg :: Eq SolvedLayoutArg where
  eq (Command n r) (Command n' r') = n == n' && r == r'
  eq (Positional n r) (Positional n' r') = n == n' && r == r'
  eq (Option n mA r) (Option n' mA' r') = n == n' && mA == mA' && r == r'
  eq EOA EOA = true
  eq Stdin Stdin = true
  eq _ _ = false

instance showSolvedLayoutArg :: Show SolvedLayoutArg where
  show (Command n r) = "Command " <> show n <> " " <> show r
  show (Positional n r) = "Positional " <> show n <> " " <> show r
  show EOA = "EOA"
  show Stdin = "Stdin"
  show (Option n mA r) = "Option " <> show n <> " " <> show mA <> " " <> show r

instance ordSolvedLayoutArg :: Ord SolvedLayoutArg where
  compare (Command n r) (Command n' r') = compare (n /\ r) (n' /\ r')
  compare (Positional n r) (Positional n' r') = compare (n /\ r) (n' /\ r')
  compare (Option n mA r) (Option n' mA' r') = compare (n /\ mA /\ r) (n' /\ mA' /\ r')
  compare EOA EOA = EQ
  compare Stdin Stdin = EQ

  -- the following table must be carefully updated:

  -- by Command
  compare (Command _ _) (Positional _ _) = GT
  compare (Command _ _) (Option _ _ _)   = GT
  compare (Command _ _) EOA              = GT
  compare (Command _ _) Stdin            = GT
  compare (Positional _ _) (Command _ _) = LT
  compare (Option _ _ _)   (Command _ _) = LT
  compare EOA              (Command _ _) = LT
  compare Stdin            (Command _ _) = LT

  compare (Positional _ _) (Option _ _ _) = GT
  compare (Positional _ _) EOA            = GT
  compare (Positional _ _) Stdin          = GT
  compare (Option _ _ _) (Positional _ _) = LT
  compare EOA            (Positional _ _) = LT
  compare Stdin          (Positional _ _) = LT

  compare (Option _ _ _) EOA   = GT
  compare (Option _ _ _) Stdin = GT
  compare EOA   (Option _ _ _) = LT
  compare Stdin (Option _ _ _) = LT

  compare EOA Stdin = GT
  compare Stdin EOA = LT

instance prettySolvedLayoutArg :: Pretty SolvedLayoutArg where
  pretty = go
    where
    go (Command n r) = n <> rep r
    go (Positional n r) = n <> rep r
    go EOA = "--"
    go Stdin = "-"
    go (Option n mA r) = pretty n <> maybe "" pretty mA <> rep r
    rep r = if r then "..." else ""

isRepeatable :: SolvedLayout -> Boolean
isRepeatable (Group           _ r _) = r
isRepeatable (Elem (Command    _ r)) = r
isRepeatable (Elem (Positional _ r)) = r
isRepeatable (Elem (Option   _ _ r)) = r
isRepeatable _ = false

setRepeatable :: Boolean -> SolvedLayout -> SolvedLayout
setRepeatable r (Group           o _ xs) = Group o r xs
setRepeatable r (Elem (Command     n _)) = Elem (Command n r)
setRepeatable r (Elem (Positional  n _)) = Elem (Positional n r)
setRepeatable r (Elem (Option   a mA _)) = Elem (Option a mA r)
setRepeatable _ x = x

setRepeatableOr :: Boolean -> SolvedLayout -> SolvedLayout
setRepeatableOr r (Group           o r' xs) = Group o (r || r') xs
setRepeatableOr r (Elem (Command     n r')) = Elem (Command n (r || r'))
setRepeatableOr r (Elem (Positional  n r')) = Elem (Positional n (r || r'))
setRepeatableOr r (Elem (Option   a mA r')) = Elem (Option a mA (r || r'))
setRepeatableOr _ x = x

isOptional :: SolvedLayout -> Boolean
isOptional (Group o _ _) = o
isOptional _ = false

isPositional :: SolvedLayoutArg -> Boolean
isPositional (Positional _ _) = true
isPositional _ = false

isCommand :: SolvedLayoutArg -> Boolean
isCommand (Command _ _) = true
isCommand _ = false

isOption :: SolvedLayoutArg -> Boolean
isOption (Option _ _ _) = true
isOption _ = false

isFlag :: SolvedLayoutArg -> Boolean
isFlag (Option _ Nothing _) = true
isFlag _ = false

isGroup :: SolvedLayout -> Boolean
isGroup (Group _ _ _) = true
isGroup _ = false

-- Is this layout considered "free"?
isFreeLayout :: SolvedLayout -> Boolean
isFreeLayout (Elem (Option _ _ _)) = true
isFreeLayout (Elem _) = false
isFreeLayout (Group _ _ xs) = all (all isFreeLayout) xs


add xmap for perturber which forms an invariant functor

module Test.StrongCheck.Perturb
  ( Attempts(..)
  , Perturb
  , Perturber(..)
  , bounded
  , boundedInt
  , perturb
  , perturber2
  , perturber3
  , perturber4
  , perturber5
  , perturber6
  , perturber7
  , perturber8
  , perturber9
  , perturber10
  , dist
  , dims
  , searchIn'
  , searchIn
  , xmap
  ) where

  import Test.StrongCheck.Gen
  import Test.StrongCheck

  import Data.Traversable
  import Data.Foldable
  import Data.Char
  import Data.Tuple
  import Data.Monoid
  import Data.Either
  import Data.Maybe
  import Data.Maybe.Unsafe
  import Data.Monoid.Sum
  import Data.Enum
  import qualified Data.String as S
  import qualified Data.Array as A

  import Math

  import Data.Function

  newtype Attempts = Attempts Number

  newtype Perturber a = Perturber {
    perturb :: Number -> a -> Gen a,
    dist    :: a -> a -> Number,
    dims    :: a -> Number }

  -- TODO: Move to Data.Functor.Invariant
  xmap :: forall a b. (a -> b) -> (b -> a) -> Perturber a -> Perturber b
  xmap f g (Perturber p) = Perturber {
    perturb : \n b -> f <$> p.perturb n (g b),
    dist    : \b1 b2 -> p.dist (g b1) (g b2),
    dims    : \b -> p.dims (g b) }

  -- | The class for things which can be perturbed.
  -- |
  -- | Laws:
  -- |   forall a, 0 >= n <= 1:
  -- |   ((>=) n) <<< dist a <$> (perturb n a) must be an infinite generator of `true` values.
  class Perturb a where
    perturb :: Number -> a -> Gen a

    dist :: a -> a -> Number

    dims :: a -> Number

  -- | Given one example, searches for other examples that satisfy a provided
  -- | boolean predicate.
  -- |
  -- | The search operates out-to-in, in an attempt to find examples that are
  -- | as far removed from the provided example as possible. The sampling size
  -- | parameter determines how many samples to take at every level of
  -- | searching, while the attempts parameter determines how many levels.
  searchIn' :: forall a. (Perturb a) => Attempts -> Number -> (a -> Boolean) -> a -> Gen a
  searchIn' (Attempts k) n f a = search0 k 1
    where search0 k d = ifThenElse (k <= 0) mempty
                        (do a' <- find f <$> (takeGen 1 $ chunked n (perturb d a))
                            fromMaybe mempty (pure <$> a') <> search0 (k - 1) (d / 2))

  -- | The same as search', but uses defaults for attempt count and sample size.
  -- | Will search a total of 10,000 examples before giving up.
  searchIn :: forall a. (Perturb a) => (a -> Boolean) -> a -> Gen a
  searchIn = searchIn' (Attempts 1000) 10

  -- | Creates a perturber for numbers that fall within the specified range.
  bounded :: Number -> Number -> Perturber Number
  bounded a b =
    let l = min a b
        u = max a b

        length = u - l

        clamp n = max l (min u n)

        perturb' d v = do dx <- arbitrary
                          return <<< clamp $ dx * length * d + v

        dist' a b = abs (a - b)

        dims' = const 1

    in  Perturber { perturb : perturb', dist : dist', dims : dims' }

  -- | Creates a perturber for integers that fall within the specified range.
  boundedInt :: Number -> Number -> Perturber Number
  boundedInt a b =
    let l = floor $ min a b
        u = ceil $ max a b

        length = u - l

        clamp n = max l (min u n)

        perturb' d v = do dx <- arbitrary
                          return <<< clamp <<< round $ dx * length * d + v

        dist' a b = abs (a - b)

        dims' = const 1

    in  Perturber { perturb : perturb', dist : dist', dims : dims' }

  perturber2 :: forall a b. (Perturb a, Perturb b) => Perturber (Tuple a b)
  perturber2 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a b) = let dx = delta 2 d in Tuple <$> perturb dx a <*> perturb dx b
          dist' (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]
          dims' (Tuple a b) = (dims a) * (dims b)

  perturber3 :: forall a b c. (Perturb a, Perturb b, Perturb c) => Perturber (Tuple a (Tuple b c))
  perturber3 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a (Tuple b c)) =
            let dx = delta 3 d
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> perturb dx c)

          dist' (Tuple a1 (Tuple b1 c1)) (Tuple a2 (Tuple b2 c2)) = toDist [dist a1 a2, dist b1 b2, dist c1 c2]

          dims' (Tuple a (Tuple b c)) = (dims a) * (dims b) * (dims c)

  perturber4 :: forall a b c d. (Perturb a, Perturb b, Perturb c, Perturb d) => Perturber (Tuple a (Tuple b (Tuple c d)))
  perturber4 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c d))) =
            let dx = delta 4 d0
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> (Tuple <$> perturb dx c <*> perturb dx d))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 d1)))
                (Tuple a2 (Tuple b2 (Tuple c2 d2))) = toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2]

          dims' (Tuple a (Tuple b (Tuple c d))) = (dims a) * (dims b) * (dims c) * (dims d)

  perturber5 :: forall a b c d e. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d e))))
  perturber5 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            let dx = delta 5 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*> perturb dx e)))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 e1))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 e2)))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e)

  perturber6 :: forall a b c d e f. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f)))))
  perturber6 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            let dx = delta 6 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*> perturb dx f))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 f1)))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 f2))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f)

  perturber7 :: forall a b c d e f g. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g))))))
  perturber7 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            let dx = delta 7 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*> perturb dx g)))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 g1))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 g2)))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g)

  perturber8 :: forall a b c d e f g h. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h)))))))
  perturber8 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            let dx = delta 8 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*> perturb dx h))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 h1)))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 h2))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2, dist h1 h2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h)

  perturber9 :: forall a b c d e f g h i. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i))))))))
  perturber9 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            let dx = delta 9 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*> perturb dx i)))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 i1))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 i2)))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i)

  perturber10 :: forall a b c d e f g h i j. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i, Perturb j) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j)))))))))
  perturber10 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            let dx = delta 10 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*>
                (Tuple <$> perturb dx i <*> perturb dx j))))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 (Tuple i1 j1)))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 (Tuple i2 j2))))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2, dist j1 j2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i) * (dims j)

  instance perturbArbEnum :: (Enum a) => Perturb (ArbEnum a) where
    perturb n e = cardPerturb1 (cardPerturb1F e n)

    dist a b = cardDist1 f a b where
      f (Cardinality sz) a b = if runArbEnum a == runArbEnum b then 0 else 1 / (2 * sz)

    dims e = enumDims f e where
      f (Cardinality sz) e = if sz <= 0 then 0 else 1

  instance perturbNumber :: Perturb Number where
    perturb 0 n = pure n
    perturb d n = do
      u <- uniform -- 'up to' d
      s <- runSignum <$> arbitrary
      return $ s * (Math.exp(k0 * (u * d)) - 1) + n

    dist a b =
      let from y = Math.log(y + 1) / k0
      in  (Math.min 1) <<< Math.abs <<< from $ Math.abs (a - b)

    dims = const 1

  instance perturbArray :: (Perturb a) => Perturb [a] where
    perturb d []  = pure $ []
    perturb 0 a   = sequence $ perturb 0 <$> a
    perturb d a   = let dx = delta (A.length a) d
                    in  sequence $ perturb dx <$> a

    dist a b = toDist $ A.zipWith dist a b

    dims = A.length

  instance perturbTuple :: (Perturb a, Perturb b) => Perturb (Tuple a b) where
    perturb d (Tuple a b) = let dx = delta 2 d
                            in  Tuple <$> (perturb dx a) <*> (perturb dx b)

    dist (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]

    dims (Tuple a b) = dims a + dims b

  instance perturbChar :: Perturb Char where
    perturb n e = if n < 1 / (2 * 65536) then pure e else arbitrary

    dist a b = if a == b then 0 else 1 / (2 * 65536)

    dims = const 1

  instance perturbBoolean :: Perturb Boolean where
    perturb n e = runArbEnum <$> perturb n (ArbEnum e)

    dist a b = dist (ArbEnum a) (ArbEnum b)

    dims = const 1

  instance perturbString :: Perturb String where
    perturb d s = S.fromCharArray <$> perturb d (S.toCharArray s)

    dist s1 s2 = dist (S.toCharArray s1) (S.toCharArray s2)

    dims = dims <<< S.toCharArray

  -- magical constants
  maxNumber :: Number
  maxNumber = 9007199254740992

  -- math
  k0 :: Number
  k0 = Math.log(maxNumber + 1)

  square :: Number -> Number
  square = flip Math.pow 2

  toDist :: [Number] -> Number
  toDist xs = Math.sqrt (sum $ square <$> xs)

  delta :: Number -> Number -> Number
  delta n d = Math.sqrt (d * d / n)

  -- FIXME: this workaround is still required as of psc 0.5.6.3
  ifThenElse p a b = if p then a else b

  -- ScopedTypeVariables
  enumDims :: forall a. (Enum a) => (Cardinality a -> a -> Number) -> a -> Number
  enumDims f = f cardinality

  -- ScopedTypeVariables
  cardPerturb1 :: forall f a. (Enum a) => (Cardinality a -> f a) -> f a
  cardPerturb1 f = f cardinality

  -- ScopedTypeVariables
  cardDist1 :: forall a. (Enum a) => (Cardinality a -> a -> a -> Number) -> a -> a -> Number
  cardDist1 f = f cardinality

  -- workaround to avoid:
  -- Attempted to unify a constrained type (Test.StrongCheck.Arbitrary u15286) =>
  -- Test.StrongCheck.Gen.Gen<u15286> with another type.
  cardPerturb1F :: forall a. (Enum a) => a -> Number -> Cardinality a -> Gen a
  cardPerturb1F a n (Cardinality sz) = if n < 1 / (2 * sz) then pure a else (runArbEnum <$> arbitrary)

module Test.StrongCheck.Perturb
  ( Attempts(..)
  , Perturb
  , Perturber(..)
  , bounded
  , boundedInt
  , perturb
  , perturber2
  , perturber3
  , perturber4
  , perturber5
  , perturber6
  , perturber7
  , perturber8
  , perturber9
  , perturber10
  , dist
  , dims
  , searchIn'
  , searchIn
  ) where

  import Test.StrongCheck.Gen
  import Test.StrongCheck

  import Data.Traversable
  import Data.Foldable
  import Data.Char
  import Data.Tuple
  import Data.Monoid
  import Data.Either
  import Data.Maybe
  import Data.Maybe.Unsafe
  import Data.Monoid.Sum
  import Data.Enum
  import qualified Data.String as S
  import qualified Data.Array as A

  import Math

  import Data.Function

  newtype Attempts = Attempts Number

  newtype Perturber a = Perturber {
    perturb :: Number -> a -> Gen a,
    dist    :: a -> a -> Number,
    dims    :: a -> Number }

  -- | The class for things which can be perturbed.
  -- |
  -- | Laws:
  -- |   forall a, 0 >= n <= 1:
  -- |   ((>=) n) <<< dist a <$> (perturb n a) must be an infinite generator of `true` values.
  class Perturb a where
    perturb :: Number -> a -> Gen a

    dist :: a -> a -> Number

    dims :: a -> Number

  -- | Given one example, searches for other examples that satisfy a provided
  -- | boolean predicate.
  -- |
  -- | The search operates out-to-in, in an attempt to find examples that are
  -- | as far removed from the provided example as possible. The sampling size
  -- | parameter determines how many samples to take at every level of
  -- | searching, while the attempts parameter determines how many levels.
  searchIn' :: forall a. (Perturb a) => Attempts -> Number -> (a -> Boolean) -> a -> Gen a
  searchIn' (Attempts k) n f a = search0 k 1
    where search0 k d = ifThenElse (k <= 0) mempty
                        (do a' <- find f <$> (takeGen 1 $ chunked n (perturb d a))
                            fromMaybe mempty (pure <$> a') <> search0 (k - 1) (d / 2))

  -- | The same as search', but uses defaults for attempt count and sample size.
  -- | Will search a total of 10,000 examples before giving up.
  searchIn :: forall a. (Perturb a) => (a -> Boolean) -> a -> Gen a
  searchIn = searchIn' (Attempts 1000) 10

  -- | Creates a perturber for numbers that fall within the specified range.
  bounded :: Number -> Number -> Perturber Number
  bounded a b =
    let l = min a b
        u = max a b

        length = u - l

        clamp n = max l (min u n)

        perturb' d v = do dx <- arbitrary
                          return <<< clamp $ dx * length * d + v

        dist' a b = abs (a - b)

        dims' = const 1

    in  Perturber { perturb : perturb', dist : dist', dims : dims' }

  -- | Creates a perturber for integers that fall within the specified range.
  boundedInt :: Number -> Number -> Perturber Number
  boundedInt a b =
    let l = floor $ min a b
        u = ceil $ max a b

        length = u - l

        clamp n = max l (min u n)

        perturb' d v = do dx <- arbitrary
                          return <<< clamp <<< round $ dx * length * d + v

        dist' a b = abs (a - b)

        dims' = const 1

    in  Perturber { perturb : perturb', dist : dist', dims : dims' }

  perturber2 :: forall a b. (Perturb a, Perturb b) => Perturber (Tuple a b)
  perturber2 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a b) = let dx = delta 2 d in Tuple <$> perturb dx a <*> perturb dx b
          dist' (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]
          dims' (Tuple a b) = (dims a) * (dims b)

  perturber3 :: forall a b c. (Perturb a, Perturb b, Perturb c) => Perturber (Tuple a (Tuple b c))
  perturber3 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a (Tuple b c)) =
            let dx = delta 3 d
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> perturb dx c)

          dist' (Tuple a1 (Tuple b1 c1)) (Tuple a2 (Tuple b2 c2)) = toDist [dist a1 a2, dist b1 b2, dist c1 c2]

          dims' (Tuple a (Tuple b c)) = (dims a) * (dims b) * (dims c)

  perturber4 :: forall a b c d. (Perturb a, Perturb b, Perturb c, Perturb d) => Perturber (Tuple a (Tuple b (Tuple c d)))
  perturber4 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c d))) =
            let dx = delta 4 d0
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> (Tuple <$> perturb dx c <*> perturb dx d))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 d1)))
                (Tuple a2 (Tuple b2 (Tuple c2 d2))) = toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2]

          dims' (Tuple a (Tuple b (Tuple c d))) = (dims a) * (dims b) * (dims c) * (dims d)

  perturber5 :: forall a b c d e. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d e))))
  perturber5 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            let dx = delta 5 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*> perturb dx e)))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 e1))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 e2)))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e)

  perturber6 :: forall a b c d e f. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f)))))
  perturber6 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            let dx = delta 6 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*> perturb dx f))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 f1)))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 f2))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f)

  perturber7 :: forall a b c d e f g. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g))))))
  perturber7 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            let dx = delta 7 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*> perturb dx g)))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 g1))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 g2)))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g)

  perturber8 :: forall a b c d e f g h. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h)))))))
  perturber8 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            let dx = delta 8 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*> perturb dx h))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 h1)))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 h2))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2, dist h1 h2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h)

  perturber9 :: forall a b c d e f g h i. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i))))))))
  perturber9 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            let dx = delta 9 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*> perturb dx i)))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 i1))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 i2)))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i)

  perturber10 :: forall a b c d e f g h i j. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i, Perturb j) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j)))))))))
  perturber10 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            let dx = delta 10 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*>
                (Tuple <$> perturb dx i <*> perturb dx j))))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 (Tuple i1 j1)))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 (Tuple i2 j2))))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2, dist j1 j2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i) * (dims j)

  instance perturbArbEnum :: (Enum a) => Perturb (ArbEnum a) where
    perturb n e = cardPerturb1 (cardPerturb1F e n)

    dist a b = cardDist1 f a b where
      f (Cardinality sz) a b = if runArbEnum a == runArbEnum b then 0 else 1 / (2 * sz)

    dims e = enumDims f e where
      f (Cardinality sz) e = if sz <= 0 then 0 else 1

  instance perturbNumber :: Perturb Number where
    perturb 0 n = pure n
    perturb d n = do
      u <- uniform -- 'up to' d
      s <- runSignum <$> arbitrary
      return $ s * (Math.exp(k0 * (u * d)) - 1) + n

    dist a b =
      let from y = Math.log(y + 1) / k0
      in  (Math.min 1) <<< Math.abs <<< from $ Math.abs (a - b)

    dims = const 1

  instance perturbArray :: (Perturb a) => Perturb [a] where
    perturb d []  = pure $ []
    perturb 0 a   = sequence $ perturb 0 <$> a
    perturb d a   = let dx = delta (A.length a) d
                    in  sequence $ perturb dx <$> a

    dist a b = toDist $ A.zipWith dist a b

    dims = A.length

  instance perturbTuple :: (Perturb a, Perturb b) => Perturb (Tuple a b) where
    perturb d (Tuple a b) = let dx = delta 2 d
                            in  Tuple <$> (perturb dx a) <*> (perturb dx b)

    dist (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]

    dims (Tuple a b) = dims a + dims b

  instance perturbChar :: Perturb Char where
    perturb n e = if n < 1 / (2 * 65536) then pure e else arbitrary

    dist a b = if a == b then 0 else 1 / (2 * 65536)

    dims = const 1

  instance perturbBoolean :: Perturb Boolean where
    perturb n e = runArbEnum <$> perturb n (ArbEnum e)

    dist a b = dist (ArbEnum a) (ArbEnum b)

    dims = const 1

  instance perturbString :: Perturb String where
    perturb d s = S.fromCharArray <$> perturb d (S.toCharArray s)

    dist s1 s2 = dist (S.toCharArray s1) (S.toCharArray s2)

    dims = dims <<< S.toCharArray

  -- magical constants
  maxNumber :: Number
  maxNumber = 9007199254740992

  -- math
  k0 :: Number
  k0 = Math.log(maxNumber + 1)

  square :: Number -> Number
  square = flip Math.pow 2

  toDist :: [Number] -> Number
  toDist xs = Math.sqrt (sum $ square <$> xs)

  delta :: Number -> Number -> Number
  delta n d = Math.sqrt (d * d / n)

  -- FIXME: this workaround is still required as of psc 0.5.6.3
  ifThenElse p a b = if p then a else b

  -- ScopedTypeVariables
  enumDims :: forall a. (Enum a) => (Cardinality a -> a -> Number) -> a -> Number
  enumDims f = f cardinality

  -- ScopedTypeVariables
  cardPerturb1 :: forall f a. (Enum a) => (Cardinality a -> f a) -> f a
  cardPerturb1 f = f cardinality

  -- ScopedTypeVariables
  cardDist1 :: forall a. (Enum a) => (Cardinality a -> a -> a -> Number) -> a -> a -> Number
  cardDist1 f = f cardinality

  -- workaround to avoid:
  -- Attempted to unify a constrained type (Test.StrongCheck.Arbitrary u15286) =>
  -- Test.StrongCheck.Gen.Gen<u15286> with another type.
  cardPerturb1F :: forall a. (Enum a) => a -> Number -> Cardinality a -> Gen a
  cardPerturb1F a n (Cardinality sz) = if n < 1 / (2 * sz) then pure a else (runArbEnum <$> arbitrary)


more geometry tests

more geometry tests

module Test.Geometry where

import Prelude
import App.Geometry
import Data.List (List(..), sort, (:))
import Math (pi)
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)

spec = do
  describe "App.Geometry" do
    describe "Arc" do
      it "should be constructed correctly" do
        (constructArc (Point 1.0 1.0) (Point 2.0 1.0)) `shouldEqual` Arc (Point 1.0 1.0) 1.0 0.0 (2.0 * pi)
        (constructArc (Point 1.0 1.0) (Point 1.0 2.0)) `shouldEqual` Arc (Point 1.0 1.0) 1.0 (pi / 2.0) (2.0 * pi)

      it "should report back firstPoint correctly" do
        firstPoint (Arc (Point 1.0 1.0) 1.0 0.0 (2.0 * pi)) `shouldEqual` Point 2.0 1.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 (pi / 2.0) (2.0 * pi)) `shouldEqual` Point 1.0 2.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 (-pi / 2.0) (2.0 * pi)) `shouldEqual` Point 1.0 0.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 pi (2.0 * pi)) `shouldEqual` Point 0.0 1.0

        (firstPoint $ constructArc (Point 10.0 10.0) (Point 20.0 20.0))
          `shouldEqual` Point 20.0 20.0

      it "should report back secondPoint correctly" do
        (secondPoint $ constructArc (Point 10.0 10.0) (Point 20.0 20.0))
          `shouldEqual` Point 20.0 20.0

        secondPoint (Arc (Point 10.0 10.0) 10.0 pi pi) `shouldEqual` Point 20.0 10.0

    describe "outboundAngle" do
      it "should produce correct angles for arcs" do
        outboundAngle (Arc (Point 10.0 10.0) 10.0 (pi/2.0) (pi/2.0)) `shouldEqual` pi
        outboundAngle (Arc (Point 10.0 10.0) 10.0 (pi/2.0) (-pi/2.0)) `shouldEqual` 0.0
        outboundAngle (Arc (Point 10.0 10.0) 10.0 (-pi/2.0) (pi/2.0)) `shouldEqual` 0.0
        outboundAngle (Arc (Point 10.0 10.0) 10.0 (-pi/2.0) (-pi/2.0)) `shouldEqual` -pi

    describe "strokeOrd" do
      it "should sort strokes by 'traverseLeftWall' order" do
        let l1 = Line (Point 10.0 10.0) (Point 20.0 10.0)
            l2 = Line (Point 10.0 10.0) (Point 20.0 20.0)
            a1 = Arc (Point 10.0 0.0) 10.0 (pi / 2.0) (-pi)
            a2 = Arc (Point 10.0 20.0) 10.0 (-pi / 2.0) pi

        sort ( l1 : a1 : a2 : Nil)`shouldEqual` (a1 : l1 : a2 : l2 : Nil)

    describe "intersect" do
      it "should find an intersection point" do
        intersect (Line (Point 0.0 0.0) (Point 1.0 1.0)) (Line (Point 0.0 1.0) (Point 1.0 0.0))
          `shouldEqual` ((Point 0.5 0.5) : Nil)

      it "should not find an intersection point for parallel lines" do
        intersect (Line (Point 0.0 0.0) (Point 0.0 1.0)) (Line (Point 1.0 0.0) (Point 1.0 1.0))
          `shouldEqual` Nil

    describe "split" do
      it "should split a line, in order" do
        split (Line (Point 0.0 0.0) (Point 1.0 1.0)) ((Point 0.2 0.2) : (Point 0.7 0.7) : (Point 0.5 0.5) : Nil)
          `shouldEqual`
          ( (Line (Point 0.0 0.0) (Point 0.2 0.2))
          : (Line (Point 0.2 0.2) (Point 0.5 0.5))
          : (Line (Point 0.5 0.5) (Point 0.7 0.7))
          : (Line (Point 0.7 0.7) (Point 1.0 1.0))
          : Nil)

module Test.Geometry where

import Prelude
import App.Geometry
import Data.List (List(..), sort, (:))
import Math (pi)
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)

spec = do
  describe "App.Geometry" do
    describe "Arc" do
      it "should be constructed correctly" do
        (constructArc (Point 1.0 1.0) (Point 2.0 1.0)) `shouldEqual` Arc (Point 1.0 1.0) 1.0 0.0 (2.0 * pi)
        (constructArc (Point 1.0 1.0) (Point 1.0 2.0)) `shouldEqual` Arc (Point 1.0 1.0) 1.0 (pi / 2.0) (2.0 * pi)

      it "should report back firstPoint correctly" do
        firstPoint (Arc (Point 1.0 1.0) 1.0 0.0 (2.0 * pi)) `shouldEqual` Point 2.0 1.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 (pi / 2.0) (2.0 * pi)) `shouldEqual` Point 1.0 2.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 (-pi / 2.0) (2.0 * pi)) `shouldEqual` Point 1.0 0.0
        firstPoint (Arc (Point 1.0 1.0) 1.0 pi (2.0 * pi)) `shouldEqual` Point 0.0 1.0

        (firstPoint $ constructArc (Point 10.0 10.0) (Point 20.0 20.0))
          `shouldEqual` Point 20.0 20.0

      it "should report back secondPoint correctly" do
        (secondPoint $ constructArc (Point 10.0 10.0) (Point 20.0 20.0))
          `shouldEqual` Point 20.0 20.0

        secondPoint (Arc (Point 10.0 10.0) 10.0 pi pi) `shouldEqual` Point 20.0 10.0

    describe "strokeOrd" do
      it "should sort strokes by curvature" do
        let l1 = Line (Point 10.0 10.0) (Point 20.0 10.0)
            a1 = Arc (Point 10.0 0.0) 10.0 (pi / 2.0) (-pi)
            a2 = Arc (Point 10.0 20.0) 10.0 (-pi / 2.0) pi

        sort ( l1 : a1 : a2 : Nil)`shouldEqual` (a1 : l1 : a2 : Nil)

    describe "intersect" do
      it "should find an intersection point" do
        intersect (Line (Point 0.0 0.0) (Point 1.0 1.0)) (Line (Point 0.0 1.0) (Point 1.0 0.0))
          `shouldEqual` ((Point 0.5 0.5) : Nil)

      it "should not find an intersection point for parallel lines" do
        intersect (Line (Point 0.0 0.0) (Point 0.0 1.0)) (Line (Point 1.0 0.0) (Point 1.0 1.0))
          `shouldEqual` Nil

    describe "split" do
      it "should split a line, in order" do
        split (Line (Point 0.0 0.0) (Point 1.0 1.0)) ((Point 0.2 0.2) : (Point 0.7 0.7) : (Point 0.5 0.5) : Nil)
          `shouldEqual`
          ( (Line (Point 0.0 0.0) (Point 0.2 0.2))
          : (Line (Point 0.2 0.2) (Point 0.5 0.5))
          : (Line (Point 0.5 0.5) (Point 0.7 0.7))
          : (Line (Point 0.7 0.7) (Point 1.0 1.0))
          : Nil)


Re-arrange tests

Re-arrange tests

module Test.Main where

import Prelude

import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.GeneratorSpec (generatorSpec)
import Test.Spec.SolverSpec (solverSpec)

main = run [consoleReporter] do
  scannerSpec
  usageParserSpec
  descParserSpec
  solverSpec
  generatorSpec

module Test.Main where

import Prelude

import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.GeneratorSpec (generatorSpec)
import Test.Spec.SolverSpec (solverSpec)

main = run [consoleReporter] do
  -- solverSpec
  -- generatorSpec
  -- scannerSpec
  -- usageParserSpec
  descParserSpec


refactored src/Parser

refactored src/Parser

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)

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(..))
import AST as AST
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

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

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

---------------------------------------------------------
-- 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 (Binary AST.emptyMeta <<< toOpTuple <<< op <$> spaced p) assoc))
        <$> x)
      <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> Atom AST.emptyMeta (AInt (-ai))
            _                -> Unary AST.emptyMeta (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
  <|> (Atom AST.emptyMeta <$> 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 -> pure $ App AST.emptyMeta 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
  pure $ IfExpr AST.emptyMeta 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 -> pure $ NTuple AST.emptyMeta (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 ->
      case me2 of
        Nothing -> pure $ PrefixOp AST.emptyMeta op
        Just e2 -> pure $ SectR AST.emptyMeta op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL AST.emptyMeta 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 ']'
  pure $ List AST.emptyMeta 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 ']'
  pure $ ArithmSeq AST.emptyMeta 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 ']'
  pure $ ListComp AST.emptyMeta 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
          pure $ Let AST.emptyMeta b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen AST.emptyMeta b e
        parseGuard = ilexe expr >>= (pure <<< Guard AST.emptyMeta)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List AST.emptyMeta ((Atom AST.emptyMeta <<< 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
  pure $ Lambda AST.emptyMeta 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
  pure $ LetExpr AST.emptyMeta binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) 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 MType) 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 MType)
binding = do
  whiteSpace
  fix $ \bnd -> do
    la <- lookAhead
    case la of
         '(' -> do
            cs <- ilexe (char '(') *> indent (bndList bnd) <* indent (char ')')
            case cs of
                 Nil        -> pure $ NTupleLit Nothing Nil
                 Cons c Nil -> pure c
                 cs'        -> pure $ NTupleLit Nothing cs'
         '[' -> do
            cs <- ilexe (char '[') *> indent (bndList bnd) <* indent (char ']')
            case cs of
                 Nil        -> pure $ ListLit Nothing Nil
                 cs'        -> pure $ ListLit Nothing cs'
         _   -> PC.try $ ilexe bndSimple

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

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

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

bndConses :: FixedIndentParser String (Binding MType)
bndConses bnd = PC.chainr1
  (PC.try <<< ilexe <<< bndInfixes $ bnd)
  (do PC.try <<< indent <<< char $ ':'
      pure $ ConsLit Nothing)

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

bndComplex :: FixedIndentParser String (Binding MType)
bndComplex bnd =
  PC.try
    (do n  <- ilexe upperCaseName
        as <- many1 bnd
        pure $ ConstrLit Nothing (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)

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(..))
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

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

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

---------------------------------------------------------
-- 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 (Binary Nothing <<< toOpTuple <<< op <$> spaced p) assoc))
        <$> x)
      <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> Atom Nothing (AInt (-ai))
            _                -> Unary Nothing (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
  <|> (Atom Nothing <$> 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 -> pure $ App Nothing 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
  pure $ IfExpr Nothing 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 -> pure $ NTuple Nothing (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 ->
      case me2 of
        Nothing -> pure $ PrefixOp Nothing op
        Just e2 -> pure $ SectR Nothing op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL Nothing 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 ']'
  pure $ List Nothing 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 ']'
  pure $ ArithmSeq Nothing 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 ']'
  pure $ ListComp Nothing 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
          pure $ Let Nothing b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen Nothing b e
        parseGuard = ilexe expr >>= (pure <<< Guard Nothing)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List Nothing ((Atom Nothing <<< 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
  pure $ Lambda Nothing 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
  pure $ LetExpr Nothing binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) 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 MType) 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 MType)
binding = do
  whiteSpace
  fix $ \bnd -> do
    la <- lookAhead
    case la of
         '(' -> do
            cs <- ilexe (char '(') *> indent (bndList bnd) <* indent (char ')')
            case cs of
                 Nil        -> pure $ NTupleLit Nothing Nil
                 Cons c Nil -> pure c
                 cs'        -> pure $ NTupleLit Nothing cs'
         '[' -> do
            cs <- ilexe (char '[') *> indent (bndList bnd) <* indent (char ']')
            case cs of
                 Nil        -> pure $ ListLit Nothing Nil
                 cs'        -> pure $ ListLit Nothing cs'
         _   -> PC.try $ ilexe bndSimple

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

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

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

bndConses :: FixedIndentParser String (Binding MType)
bndConses bnd = PC.chainr1
  (PC.try <<< ilexe <<< bndInfixes $ bnd)
  (do PC.try <<< indent <<< char $ ':'
      pure $ ConsLit Nothing)

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

bndComplex :: FixedIndentParser String (Binding MType)
bndComplex bnd =
  PC.try
    (do n  <- ilexe upperCaseName
        as <- many1 bnd
        pure $ ConstrLit Nothing (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