Add roles declarations to allow safe coercions (#194)

module Effect.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , invincible
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , effectCanceler
  , fiberCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Lazy (class Lazy)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Parallel.Class (sequential, parallel) as Exports
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.Duration (Milliseconds(..)) as Exports
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error, error)
import Effect.Exception (Error, error, message) as Exports
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff a` is an asynchronous computation with effects. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using
-- | `makeAff` or `liftEffect`.
foreign import data Aff ∷ Type → Type

type role Aff representational

instance functorAff ∷ Functor Aff where
  map = _map

instance applyAff ∷ Apply Aff where
  apply = ap

instance applicativeAff ∷ Applicative Aff where
  pure = _pure

instance bindAff ∷ Bind Aff where
  bind = _bind

instance monadAff ∷ Monad Aff

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff a) where
  mempty = pure mempty

instance altAff ∷ Alt Aff where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus Aff where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec Aff where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error Aff where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error Aff where
  catchError = _catchError

instance monadEffectAff ∷ MonadEffect Aff where
  liftEffect = _liftEffect

instance lazyAff ∷ Lazy (Aff a) where
  defer f = pure unit >>= f

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ Type → Type

type role ParAff representational

instance functorParAff ∷ Functor ParAff where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply ParAff where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative ParAff where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt ParAff where
  alt = _parAffAlt

instance plusParAff ∷ Plus ParAff where
  empty = parallel empty

instance alternativeParAff ∷ Alternative ParAff

instance parallelAff ∷ Parallel ParAff Aff where
  parallel = (unsafeCoerce ∷ ∀ a. Aff a → ParAff a)
  sequential = _sequential

type OnComplete a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Effect Unit) → Effect Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber a = Fiber
  { run ∷ Effect Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Effect Unit) (Effect (Effect Unit))
  , join ∷ (Either Error a → Effect Unit) → Effect (Effect Unit)
  , onComplete ∷ OnComplete a → Effect (Effect Unit)
  , isSuspended ∷ Effect Boolean
  }

instance functorFiber ∷ Functor Fiber where
  map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply Fiber where
  apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative Fiber where
  pure a = unsafePerformEffect (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ a. Error → Fiber a → Aff Unit
killFiber e (Fiber t) = liftEffect t.isSuspended >>= if _
  then liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit))
  else makeAff \k → effectCanceler <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ Fiber ~> Aff
joinFiber (Fiber t) = makeAff \k → effectCanceler <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler = Canceler (Error → Aff Unit)

derive instance newtypeCanceler ∷ Newtype Canceler _

instance semigroupCanceler ∷ Semigroup Canceler where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid Canceler where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ Canceler
nonCanceler = Canceler (const (pure unit))

-- | A canceler from an Effect action.
effectCanceler ∷ Effect Unit → Canceler
effectCanceler = Canceler <<< const <<< liftEffect

-- | A canceler from a Fiber.
fiberCanceler ∷ ∀ a. Fiber a → Canceler
fiberCanceler = Canceler <<< flip killFiber

-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`.
launchAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`.
launchAff_ ∷ ∀ a. Aff a → Effect Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runAff k aff = launchAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ a. Aff a → Aff (Fiber a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ a. Aff a → Aff (Fiber a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ Milliseconds → Aff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ a. Aff a
never = makeAff \_ → pure mempty

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ a. Aff a → Aff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ a. Aff a → Aff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ a. Aff Unit → Aff a → Aff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
invincible ∷ ∀ a. Aff a → Aff a
invincible a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ a. Aff a → Canceler → Aff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised a =
  { fiber ∷ Fiber a
  , supervisor ∷ Supervisor
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ a. Aff a → Aff a
supervise aff =
  generalBracket (liftEffect acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised a → Aff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Effect (Supervised a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ Type
foreign import _pure ∷ ∀ a. a → Aff a
foreign import _throwError ∷ ∀ a. Error → Aff a
foreign import _catchError ∷ ∀ a. Aff a → (Error → Aff a) → Aff a
foreign import _fork ∷ ∀ a. Boolean → Aff a → Aff (Fiber a)
foreign import _map ∷ ∀ a b. (a → b) → Aff a → Aff b
foreign import _bind ∷ ∀ a b. Aff a → (a → Aff b) → Aff b
foreign import _delay ∷ ∀ a. Fn.Fn2 (Unit → Either a Unit) Number (Aff Unit)
foreign import _liftEffect ∷ ∀ a. Effect a → Aff a
foreign import _parAffMap ∷ ∀ a b. (a → b) → ParAff a → ParAff b
foreign import _parAffApply ∷ ∀ a b. ParAff (a → b) → ParAff a → ParAff b
foreign import _parAffAlt ∷ ∀ a. ParAff a → ParAff a → ParAff a
foreign import _makeFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Fiber a))
foreign import _makeSupervisedFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Supervised a))
foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler)
foreign import _sequential ∷ ParAff ~> Aff

type BracketConditions a b =
  { killed ∷ Error → a → Aff Unit
  , failed ∷ Error → a → Aff Unit
  , completed ∷ b → a → Aff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b

-- | Constructs an `Aff` from low-level `Effect` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a

makeFiber ∷ ∀ a. Aff a → Effect (Fiber a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Effect.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , invincible
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , effectCanceler
  , fiberCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Lazy (class Lazy)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Parallel.Class (sequential, parallel) as Exports
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.Duration (Milliseconds(..)) as Exports
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error, error)
import Effect.Exception (Error, error, message) as Exports
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff a` is an asynchronous computation with effects. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using
-- | `makeAff` or `liftEffect`.
foreign import data Aff ∷ Type → Type

instance functorAff ∷ Functor Aff where
  map = _map

instance applyAff ∷ Apply Aff where
  apply = ap

instance applicativeAff ∷ Applicative Aff where
  pure = _pure

instance bindAff ∷ Bind Aff where
  bind = _bind

instance monadAff ∷ Monad Aff

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff a) where
  mempty = pure mempty

instance altAff ∷ Alt Aff where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus Aff where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec Aff where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error Aff where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error Aff where
  catchError = _catchError

instance monadEffectAff ∷ MonadEffect Aff where
  liftEffect = _liftEffect

instance lazyAff ∷ Lazy (Aff a) where
  defer f = pure unit >>= f

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ Type → Type

instance functorParAff ∷ Functor ParAff where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply ParAff where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative ParAff where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt ParAff where
  alt = _parAffAlt

instance plusParAff ∷ Plus ParAff where
  empty = parallel empty

instance alternativeParAff ∷ Alternative ParAff

instance parallelAff ∷ Parallel ParAff Aff where
  parallel = (unsafeCoerce ∷ ∀ a. Aff a → ParAff a)
  sequential = _sequential

type OnComplete a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Effect Unit) → Effect Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber a = Fiber
  { run ∷ Effect Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Effect Unit) (Effect (Effect Unit))
  , join ∷ (Either Error a → Effect Unit) → Effect (Effect Unit)
  , onComplete ∷ OnComplete a → Effect (Effect Unit)
  , isSuspended ∷ Effect Boolean
  }

instance functorFiber ∷ Functor Fiber where
  map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply Fiber where
  apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative Fiber where
  pure a = unsafePerformEffect (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ a. Error → Fiber a → Aff Unit
killFiber e (Fiber t) = liftEffect t.isSuspended >>= if _
  then liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit))
  else makeAff \k → effectCanceler <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ Fiber ~> Aff
joinFiber (Fiber t) = makeAff \k → effectCanceler <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler = Canceler (Error → Aff Unit)

derive instance newtypeCanceler ∷ Newtype Canceler _

instance semigroupCanceler ∷ Semigroup Canceler where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid Canceler where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ Canceler
nonCanceler = Canceler (const (pure unit))

-- | A canceler from an Effect action.
effectCanceler ∷ Effect Unit → Canceler
effectCanceler = Canceler <<< const <<< liftEffect

-- | A canceler from a Fiber.
fiberCanceler ∷ ∀ a. Fiber a → Canceler
fiberCanceler = Canceler <<< flip killFiber

-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`.
launchAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`.
launchAff_ ∷ ∀ a. Aff a → Effect Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runAff k aff = launchAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ a. Aff a → Aff (Fiber a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ a. Aff a → Aff (Fiber a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ Milliseconds → Aff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ a. Aff a
never = makeAff \_ → pure mempty

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ a. Aff a → Aff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ a. Aff a → Aff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ a. Aff Unit → Aff a → Aff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
invincible ∷ ∀ a. Aff a → Aff a
invincible a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ a. Aff a → Canceler → Aff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised a =
  { fiber ∷ Fiber a
  , supervisor ∷ Supervisor
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ a. Aff a → Aff a
supervise aff =
  generalBracket (liftEffect acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised a → Aff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Effect (Supervised a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ Type
foreign import _pure ∷ ∀ a. a → Aff a
foreign import _throwError ∷ ∀ a. Error → Aff a
foreign import _catchError ∷ ∀ a. Aff a → (Error → Aff a) → Aff a
foreign import _fork ∷ ∀ a. Boolean → Aff a → Aff (Fiber a)
foreign import _map ∷ ∀ a b. (a → b) → Aff a → Aff b
foreign import _bind ∷ ∀ a b. Aff a → (a → Aff b) → Aff b
foreign import _delay ∷ ∀ a. Fn.Fn2 (Unit → Either a Unit) Number (Aff Unit)
foreign import _liftEffect ∷ ∀ a. Effect a → Aff a
foreign import _parAffMap ∷ ∀ a b. (a → b) → ParAff a → ParAff b
foreign import _parAffApply ∷ ∀ a b. ParAff (a → b) → ParAff a → ParAff b
foreign import _parAffAlt ∷ ∀ a. ParAff a → ParAff a → ParAff a
foreign import _makeFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Fiber a))
foreign import _makeSupervisedFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Supervised a))
foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler)
foreign import _sequential ∷ ParAff ~> Aff

type BracketConditions a b =
  { killed ∷ Error → a → Aff Unit
  , failed ∷ Error → a → Aff Unit
  , completed ∷ b → a → Aff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b

-- | Constructs an `Aff` from low-level `Effect` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a

makeFiber ∷ ∀ a. Aff a → Effect (Fiber a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"


Don't use a Set when gathering Either options

This makes it obvious when we have classes with the same name.
Without this change we could get `Either<Foo>` when in reality
we might have three `Foo`s, so now it's `Either<Foo,Foo,Foo>`.

Original commit 571042c2f07554d7e960960e8df23ec7063e92e0

module CSharp
    ( renderer
    ) where

import Doc
import IR
import Prelude
import Types

import Data.Foldable (for_, intercalate)
import Data.List (List, fromFoldable, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String.Util (capitalize, camelCase)
import Data.Tuple as Tuple

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , render: renderCSharp
    }

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

nullableFromSet :: Set.Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: IRGraph -> Set.Set IRType -> String
renderUnionToCSharp graph s =
    case nullableFromSet s of
    Just x -> if isValueType x then renderTypeToCSharp graph x <> "?" else renderTypeToCSharp graph x
    Nothing -> "Either<" <> intercalate ", " (map (renderTypeToCSharp graph) (L.fromFoldable s)) <> ">"

renderTypeToCSharp :: IRGraph -> IRType -> String
renderTypeToCSharp graph = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp graph a <> "[]"
    IRClass i ->
        let IRClassData { names: names, properties } = getClassFromGraph graph i
        in
            csNameStyle $ combineNames names
    IRUnion types -> renderUnionToCSharp graph types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize

renderCSharp :: IRGraph -> L.List IRClassData -> Doc Unit
renderCSharp graph classes = do
    line "namespace QuickType"
    line "{"
    blank
    indent do
        line "using System.Net;"
        line "using Newtonsoft.Json;"
        blank
        for_ classes \cls -> do
            renderCSharpClass graph cls
            blank
    line "}"

renderCSharpClass :: IRGraph -> IRClassData -> Doc Unit
renderCSharpClass graph (IRClassData { names, properties }) = do
    line $ words ["class", csNameStyle $ combineNames names]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> do
            line do
                string "[JsonProperty(\""
                string pname
                string "\")]"
            line do
                string "public "
                string $ renderTypeToCSharp graph ptype
                words ["", csNameStyle pname, "{ get; set; }"]
                blank

        -- TODO don't rely on 'TopLevel'
        when (names == Set.singleton "TopLevel") do
            line "// Loading helpers"
            line "public static TopLevel FromJson(string json) => JsonConvert.DeserializeObject<TopLevel>(json);"
            line "public static TopLevel FromUrl(string url) => FromJson(new WebClient().DownloadString(url));"
    line "}"

module CSharp
    ( renderer
    ) where

import Doc
import IR
import Prelude
import Types

import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String.Util (capitalize, camelCase)
import Data.Tuple as Tuple

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , render: renderCSharp
    }

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

nullableFromSet :: Set.Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: IRGraph -> Set.Set IRType -> String
renderUnionToCSharp graph s =
    case nullableFromSet s of
    Just x -> if isValueType x then renderTypeToCSharp graph x <> "?" else renderTypeToCSharp graph x
    Nothing -> "Either<" <> intercalate ", " (Set.map (renderTypeToCSharp graph) s) <> ">"

renderTypeToCSharp :: IRGraph -> IRType -> String
renderTypeToCSharp graph = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp graph a <> "[]"
    IRClass i ->
        let IRClassData { names: names, properties } = getClassFromGraph graph i
        in
            csNameStyle $ combineNames names
    IRUnion types -> renderUnionToCSharp graph types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize

renderCSharp :: IRGraph -> L.List IRClassData -> Doc Unit
renderCSharp graph classes = do
    line "namespace QuickType"
    line "{"
    blank
    indent do
        line "using System.Net;"
        line "using Newtonsoft.Json;"
        blank
        for_ classes \cls -> do
            renderCSharpClass graph cls
            blank
    line "}"

renderCSharpClass :: IRGraph -> IRClassData -> Doc Unit
renderCSharpClass graph (IRClassData { names, properties }) = do
    line $ words ["class", csNameStyle $ combineNames names]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> do
            line do
                string "[JsonProperty(\""
                string pname
                string "\")]"
            line do
                string "public "
                string $ renderTypeToCSharp graph ptype
                words ["", csNameStyle pname, "{ get; set; }"]
                blank

        -- TODO don't rely on 'TopLevel'
        when (names == Set.singleton "TopLevel") do
            line "// Loading helpers"
            line "public static TopLevel FromJson(string json) => JsonConvert.DeserializeObject<TopLevel>(json);"
            line "public static TopLevel FromUrl(string url) => FromJson(new WebClient().DownloadString(url));"
    line "}"


Fix: Correctly parse spaces in lists

Fix: Correctly parse spaces in lists

module Parser where

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

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

import AST

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

parse :: forall a. Parser String a -> String -> Either String a
parse p s = case runParser s p of
  Left err -> Left $ show err
  Right a  -> Right a

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

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

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

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

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

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

parseExpr :: String -> Either String Expr
parseExpr = parse (eatSpaces *> expr)

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string "," *> eatSpaces))
  eatSpaces
  string "]"
  return ls

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

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = bracket (try sectR <|> sectL)
  where
  sectR = do
    op <- choice opList
    eatSpaces
    e <- expr
    return $ SectR op e
  sectL = do
    e <- expr
    eatSpaces
    op <- choice opList
    return $ SectL e op

opList :: [Parser String Op]
opList =
  [ opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string "*")     Mul
  , opP (string "`div`") Div
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "&&")    And
  , opP (string "||")    Or
  ]

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

termSect :: Parser String Expr -> Parser String Expr
termSect expr = try (section (base expr)) <|> base expr

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

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

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

term6neg :: Parser String Expr -> Parser String Expr
term6neg expr = try negation <|> (term7l expr)
  where
  negation = do
    string "-"
    eatSpaces
    e <- (term7l expr)
    return $ Unary Sub e

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

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

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

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

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

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

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

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> consLit binding <|> listLit binding

---------------------------------------
-- Parsers for the 'Definition' type
---------------------------------------

parseDefs :: String -> Either String [Definition]
parseDefs = parse (skipSpaces *> defs)

def :: Parser String Definition
def = do
  defName <- name
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "="
  eatSpaces
  body <- expr
  return $ Def defName binds body

defs :: Parser String [Definition]
defs = def `sepEndBy` skipSpaces

module Parser where

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

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

import AST

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

parse :: forall a. Parser String a -> String -> Either String a
parse p s = case runParser s p of
  Left err -> Left $ show err
  Right a  -> Right a

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

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

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

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

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

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

parseExpr :: String -> Either String Expr
parseExpr = parse (eatSpaces *> expr)

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return ls

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

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = bracket (try sectR <|> sectL)
  where
  sectR = do
    op <- choice opList
    eatSpaces
    e <- expr
    return $ SectR op e
  sectL = do
    e <- expr
    eatSpaces
    op <- choice opList
    return $ SectL e op

opList :: [Parser String Op]
opList =
  [ opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string "*")     Mul
  , opP (string "`div`") Div
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "&&")    And
  , opP (string "||")    Or
  ]

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

termSect :: Parser String Expr -> Parser String Expr
termSect expr = try (section (base expr)) <|> base expr

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

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

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

term6neg :: Parser String Expr -> Parser String Expr
term6neg expr = try negation <|> (term7l expr)
  where
  negation = do
    string "-"
    eatSpaces
    e <- (term7l expr)
    return $ Unary Sub e

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

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

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

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

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

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

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

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> consLit binding <|> listLit binding

---------------------------------------
-- Parsers for the 'Definition' type
---------------------------------------

parseDefs :: String -> Either String [Definition]
parseDefs = parse (skipSpaces *> defs)

def :: Parser String Definition
def = do
  defName <- name
  eatSpaces
  binds <- binding `sepEndBy` eatSpaces
  string "="
  eatSpaces
  body <- expr
  return $ Def defName binds body

defs :: Parser String [Definition]
defs = def `sepEndBy` skipSpaces


Fix zipWith for arrays of differing length

module Data.Array
  ( (:)
  , singleton
  , head
  , tail
  , map
  , length
  , indexOf
  , lastIndexOf
  , concat
  , joinWith
  , reverse
  , drop
  , take
  , slice
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , isEmpty
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Prelude
import Data.Maybe

infixr 6 :

(:) :: forall a. a -> [a] -> [a]
(:) a = concat [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _ = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _ = Nothing

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import indexOf
  "function indexOf (l) {\
  \  return function (e) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import elem
  "function elem(l) {\
  \  return function (e) {\
  \    return l.indexOf(e) !== -1;\
  \  };\
  \}" :: forall a. [a] -> a -> Boolean

foreign import lastIndexOf
  "function lastIndexOf (l) {\
  \  return function (e) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import concat
  "function concat (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import joinWith
  "function joinWith (l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

foreign import take
  "function take (n) {\
  \  return function (l) {\
  \    return l.slice(0, n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1[index] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

isEmpty :: forall a. [a] -> Boolean
isEmpty [] = true
isEmpty _ = false

range :: Number -> Number -> [Number]
range lo hi | lo > hi = []
range lo hi = lo : range (lo + 1) hi

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance showArray :: (Show a) => Show [a] where
  show xs = "[" ++ joinWith (map show xs) "," ++ "]"

instance monadArray :: Monad [] where
  return = singleton
  (>>=) = flip concatMap

instance applicativeArray :: Applicative [] where
  pure = return
  (<*>) = ap

instance functorArray :: Functor [] where
  (<$>) = map

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = concat

module Data.Array
  ( (:)
  , singleton
  , head
  , tail
  , map
  , length
  , indexOf
  , lastIndexOf
  , concat
  , joinWith
  , reverse
  , drop
  , take
  , slice
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , isEmpty
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Prelude
import Data.Maybe

infixr 6 :

(:) :: forall a. a -> [a] -> [a]
(:) a = concat [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _ = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _ = Nothing

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import indexOf
  "function indexOf (l) {\
  \  return function (e) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import elem
  "function elem(l) {\
  \  return function (e) {\
  \    return l.indexOf(e) !== -1;\
  \  };\
  \}" :: forall a. [a] -> a -> Boolean

foreign import lastIndexOf
  "function lastIndexOf (l) {\
  \  return function (e) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import concat
  "function concat (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import joinWith
  "function joinWith (l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

foreign import take
  "function take (n) {\
  \  return function (l) {\
  \    return l.slice(0, n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1[index] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

isEmpty :: forall a. [a] -> Boolean
isEmpty [] = true
isEmpty _ = false

range :: Number -> Number -> [Number]
range lo hi | lo > hi = []
range lo hi = lo : range (lo + 1) hi

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length > ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance showArray :: (Show a) => Show [a] where
  show xs = "[" ++ joinWith (map show xs) "," ++ "]"

instance monadArray :: Monad [] where
  return = singleton
  (>>=) = flip concatMap

instance applicativeArray :: Applicative [] where
  pure = return
  (<*>) = ap

instance functorArray :: Functor [] where
  (<$>) = map

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = concat


add a derived superclass instance for Form

module Hyper.Form
       ( Form(..)
       , optional
       , required
       , parseForm
       , fromForm
       , toForm
       , class FromForm
       , class ToForm
       , parseFromForm
       ) where

import Prelude
import Data.Tuple as Tuple
import Control.IxMonad (ibind, ipure, (:>>=))
import Control.Monad.Error.Class (throwError)
import Data.Array (head)
import Data.Either (Either(..))
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.MediaType (MediaType(MediaType))
import Data.MediaType.Common (applicationFormURLEncoded)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, unwrap)
import Data.StrMap (lookup)
import Data.String (Pattern(Pattern), split)
import Data.Tuple (Tuple)
import Hyper.Conn (Conn)
import Hyper.Form.Urlencoded (parseUrlencoded)
import Hyper.Middleware (Middleware)
import Hyper.Middleware.Class (getConn)
import Hyper.Request (class Request, class ReadableBody, getRequestData, readBody)

newtype Form = Form (Array (Tuple String (Maybe String)))

derive instance newtypeForm :: Newtype Form _
derive instance genericForm :: Generic Form
derive newtype instance eqForm :: Eq Form
derive newtype instance ordForm :: Ord Form
derive newtype instance showForm :: Show Form
derive newtype instance semigroupForm :: Semigroup Form
derive newtype instance monoidForm :: Monoid Form

optional :: String -> Form -> Maybe String
optional key = do
  unwrap
  >>> Tuple.lookup key
  >>> flip bind id

required :: String -> Form -> Either String String
required key =
  optional key
  >>> maybe (throwError ("Missing field: " <> key)) pure

parseContentMediaType :: String -> Maybe MediaType
parseContentMediaType = split (Pattern ";")
                        >>> head
                        >>> map MediaType

parseForm ∷ forall m req res c
  .  Monad m
  => Request req m
  => ReadableBody req m String
  => Middleware
      m
      (Conn req res c)
      (Conn req res c)
      (Either String Form)
parseForm = do
  conn <- getConn
  { headers } <- getRequestData
  body <- readBody
  case lookup "content-type" headers >>= parseContentMediaType of
    Nothing ->
      ipure (Left "Missing or invalid content-type header.")
    Just mediaType | mediaType == applicationFormURLEncoded ->
      ipure (Form <$> parseUrlencoded body)
    Just mediaType ->
      ipure (Left ("Cannot parse media of type: " <> show mediaType))
  where bind = ibind

class ToForm a where
  toForm ∷ a → Form

class FromForm a where
  fromForm ∷ Form → Either String a

parseFromForm ∷ forall m req res c a
  .  Monad m
  => Request req m
  => ReadableBody req m String
  => FromForm a
  => Middleware
     m
     (Conn req res c)
     (Conn req res c)
     (Either String a)
parseFromForm =
  parseForm :>>=
  case _ of
    Left err -> ipure (Left err)
    Right form -> ipure (fromForm form)

module Hyper.Form
       ( Form(..)
       , optional
       , required
       , parseForm
       , fromForm
       , toForm
       , class FromForm
       , class ToForm
       , parseFromForm
       ) where

import Prelude
import Data.Tuple as Tuple
import Control.IxMonad (ibind, ipure, (:>>=))
import Control.Monad.Error.Class (throwError)
import Data.Array (head)
import Data.Either (Either(..))
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.MediaType (MediaType(MediaType))
import Data.MediaType.Common (applicationFormURLEncoded)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, unwrap)
import Data.StrMap (lookup)
import Data.String (Pattern(Pattern), split)
import Data.Tuple (Tuple)
import Hyper.Conn (Conn)
import Hyper.Form.Urlencoded (parseUrlencoded)
import Hyper.Middleware (Middleware)
import Hyper.Middleware.Class (getConn)
import Hyper.Request (class Request, class ReadableBody, getRequestData, readBody)

newtype Form = Form (Array (Tuple String (Maybe String)))

derive instance newtypeForm :: Newtype Form _
derive instance genericForm :: Generic Form
derive newtype instance eqForm :: Eq Form
derive newtype instance ordForm :: Ord Form
derive newtype instance showForm :: Show Form
derive newtype instance monoidForm :: Monoid Form

optional :: String -> Form -> Maybe String
optional key = do
  unwrap
  >>> Tuple.lookup key
  >>> flip bind id

required :: String -> Form -> Either String String
required key =
  optional key
  >>> maybe (throwError ("Missing field: " <> key)) pure

parseContentMediaType :: String -> Maybe MediaType
parseContentMediaType = split (Pattern ";")
                        >>> head
                        >>> map MediaType

parseForm ∷ forall m req res c
  .  Monad m
  => Request req m
  => ReadableBody req m String
  => Middleware
      m
      (Conn req res c)
      (Conn req res c)
      (Either String Form)
parseForm = do
  conn <- getConn
  { headers } <- getRequestData
  body <- readBody
  case lookup "content-type" headers >>= parseContentMediaType of
    Nothing ->
      ipure (Left "Missing or invalid content-type header.")
    Just mediaType | mediaType == applicationFormURLEncoded ->
      ipure (Form <$> parseUrlencoded body)
    Just mediaType ->
      ipure (Left ("Cannot parse media of type: " <> show mediaType))
  where bind = ibind

class ToForm a where
  toForm ∷ a → Form

class FromForm a where
  fromForm ∷ Form → Either String a

parseFromForm ∷ forall m req res c a
  .  Monad m
  => Request req m
  => ReadableBody req m String
  => FromForm a
  => Middleware
     m
     (Conn req res c)
     (Conn req res c)
     (Either String a)
parseFromForm =
  parseForm :>>=
  case _ of
    Left err -> ipure (Left err)
    Right form -> ipure (fromForm form)


More consistent quotes

More consistent quotes

Original commit 2e954347616edc4797284eda7d3538c1c3988a21

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Either as Either
import Data.Foldable (all, for_, intercalate, maximum)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert"]
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

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

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c = isLetter c || generalCategory c == Just LetterNumber

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

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

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion _) -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

quote :: String -> String
quote s = "\"" <> s <> "\""

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = quote s
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just _ | all isStartCharacter (Str.toCharArray s) -> s
                   | otherwise -> quote s

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topType <- getTopLevel
    topFull <- renderType topType
    topClassName <- getContainedClassName topType
    module_ <- getTopLevelNameGiven
    let imports =
            case topClassName of
                Just name -> {
                    basic:    "{ " <> name  <> " }",
                    advanced: "{ " <> name  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> module_,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this data:
//
//   import """ <> imports.basic  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = JSON.parse(json);
//
// Or use Convert.fromJson to perform a type-checking conversion:
//
//   import """ <> imports.advanced  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure $ quote "undefined"
    IRNull -> pure $ quote "undefined"
    IRInteger -> pure $ quote "number"
    IRDouble -> pure $ quote "number"
    IRBool -> pure $ quote "boolean"
    IRString -> pure $ quote "string"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object(" <> quote name <> ")"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == "undefined") return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`["${prop}"]`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Either as Either
import Data.Foldable (all, for_, intercalate, maximum)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert"]
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

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

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c = isLetter c || generalCategory c == Just LetterNumber

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

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

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion _) -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "'" <> s <> "'"
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just _ | all isStartCharacter (Str.toCharArray s) -> s
                   | otherwise -> "'" <> s <> "'"

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topType <- getTopLevel
    topFull <- renderType topType
    topClassName <- getContainedClassName topType
    module_ <- getTopLevelNameGiven
    let imports =
            case topClassName of
                Just name -> {
                    basic:    "{ " <> name  <> " }",
                    advanced: "{ " <> name  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> module_,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this data:
//
//   import """ <> imports.basic  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = JSON.parse(json);
//
// Or use Convert.fromJson to perform a type-checking conversion:
//
//   import """ <> imports.advanced  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""


better map

better map

module LevelMap where

import Data.Either
import Data.Tuple
import Data.Char (charString)
import Data.String (split, trim, toCharArray, joinWith)
import Control.Lens ((~))
import Control.Monad (unless)
import Math (floor)
import Data.Array (map, filter, null, reverse, (!!), range, concatMap,
                   concat, length)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Traversable (for, sequence)
import Data.Foldable (mconcat, all)

import Utils
import Types hiding (Direction(..))

-- the number of tiles along one side of a level map.
tilesAlongSide :: Number
tilesAlongSide = 17

-- the height or width in a level, in blocks.
mapSize :: Number
mapSize = tileSize * tilesAlongSide

normalize :: Tile -> Tuple Number Tile
normalize t =
  case t of
    Intersection       -> (0 ~ Intersection)
    TeeJunctionUp      -> (0 ~ TeeJunctionUp)
    TeeJunctionRight   -> (1 ~ TeeJunctionUp)
    TeeJunctionDown    -> (2 ~ TeeJunctionUp)
    TeeJunctionLeft    -> (3 ~ TeeJunctionUp)
    CornerUpRight      -> (0 ~ CornerUpRight)
    CornerRightDown    -> (1 ~ CornerUpRight)
    CornerDownLeft     -> (2 ~ CornerUpRight)
    CornerLeftUp       -> (3 ~ CornerUpRight)
    StraightHorizontal -> (0 ~ StraightHorizontal)
    StraightVertical   -> (1 ~ StraightHorizontal)
    Inaccessible       -> (0 ~ Inaccessible)

toBlockTile :: Tile -> BlockTile
toBlockTile t =
  case normalize t of
    Tuple n t' -> applyN n rotateCW (convert t')
  where
  convert t =
    case t of
      Intersection       -> intersectionB
      TeeJunctionUp      -> teeJunctionUpB
      CornerUpRight      -> cornerUpRightB
      StraightHorizontal -> straightHorizontalB
      Inaccessible       -> inaccessibleB

mkBlockTile :: BlockTile -> BlockTile
mkBlockTile b =
  let rightLength :: forall a. [a] -> Boolean
      rightLength x = length x == tileSize
      ok = rightLength b && all rightLength b
  in  if ok then b else error "bad dimensions for BlockTile"

rotateCW :: BlockTile -> BlockTile
rotateCW = map reverse >>> transpose

debugShowBlockTile :: BlockTile -> String
debugShowBlockTile bt =
  let rows = transpose bt
      showRow = map showBlock >>> joinWith ""
      showBlock b =
        case b of
          Wall -> "#"
          Empty -> " "
  in  joinWith "\n" (map showRow rows)

concatTiles :: [[Tile]] -> Maybe [[Block]]
concatTiles =
  map (map toBlockTile) >>> map concatTileRow >>> sequence >>> fmap concat

concatTileRow :: [BlockTile] -> Maybe [[Block]]
concatTileRow ts =
    let r = range 0 (tileSize - 1)
        getRow n t = t !! n
        getRowComponents n = map (getRow n) ts
        maybes = map (getRowComponents >>> mconcat) r
    in  sequence maybes

-- The number of blocks along one side of a tile in the level map. This allows
-- a simpler model, since any given object may exist in only one block.
-- Should be an odd number, since any tile should have one central block.
tileSize :: Number
tileSize = 11

halfTile :: Number
halfTile = floor (tileSize / 2)

mirror :: forall a. a -> a -> [a]
mirror x y =
    let xs = replicate halfTile x
    in xs <> [y] <> xs

intersectionB :: BlockTile
intersectionB =
    let normalRow = mirror Wall Empty
        centralRow = replicate tileSize Empty
    in mkBlockTile $ mirror normalRow centralRow

teeJunctionUpB :: BlockTile
teeJunctionUpB =
    let normalCol  = mirror Wall Empty
        centralCol = replicate halfTile Empty <>
                        [Empty] <>
                        replicate halfTile Wall
    in  mkBlockTile $ mirror normalCol centralCol

cornerUpRightB :: BlockTile
cornerUpRightB =
    let upperRow = mirror Wall Empty
        centralRow = replicate halfTile Wall <> replicate (halfTile + 1) Empty
        lowerRow = replicate tileSize Wall
        byRows =
          replicate halfTile upperRow <>
              [centralRow] <>
              replicate halfTile lowerRow
    in  mkBlockTile $ transpose byRows

straightHorizontalB :: BlockTile
straightHorizontalB =
  let col = mirror Wall Empty
  in  mkBlockTile $ replicate tileSize col

inaccessibleB :: BlockTile
inaccessibleB = mkBlockTile $ replicate tileSize (replicate tileSize Wall)

basicTileMap :: [[Tile]]
basicTileMap =
    let n = tilesAlongSide - 2
        leftCol =
            [CornerRightDown] <>
                replicate n TeeJunctionDown <>
                [CornerUpRight]
        centralCol =
            [TeeJunctionDown] <>
                replicate n Intersection <>
                [TeeJunctionUp]
        rightCol =
            [CornerDownLeft] <>
                replicate n TeeJunctionUp <>
                [CornerLeftUp]
    in [leftCol] <> replicate n centralCol <> [rightCol]

fromString :: String -> Either String [[Tile]]
fromString str = parseLevelMapString str >>= constructLevelMap

-- 'Wall' or 'Empty'
data BasicTile = W | E

fail = Left

parseLevelMapString :: String -> Either String [[BasicTile]]
parseLevelMapString str = do
  let toLines =
    split "\n" >>>
      map (trim >>> toCharArray) >>>
      filter (not <<< null) >>>
      transpose

  let lines = toLines str
  unless (rightLength lines && all rightLength lines) $
    fail $ "expected a square levelmap; dimensions should be " <>
            show tilesAlongSide <> " by " <> show tilesAlongSide

  for lines $ \line ->
    for line $ \char ->
      let c = charString char
      in case c of
        "#" -> return W
        "_" -> return E
        _   -> fail $ "unexpected char '" <> c <> "'; expected '#' or '_'"

  where
  rightLength :: forall a. [a] -> Boolean
  rightLength x = length x == tilesAlongSide

constructLevelMap :: [[BasicTile]] -> Either String [[Tile]]
constructLevelMap basicTiles = do
  let tileIndices = range 0 (tilesAlongSide - 1)
  let b i j = basicTiles !! i >>= (\r -> r !! j)

  for tileIndices $ \i ->
    for tileIndices $ \j ->
      let centre = fromJust $ b i j
          above = fromMaybe W $ b i (j-1)
          below = fromMaybe W $ b i (j+1)
          right = fromMaybe W $ b (i+1) j
          left  = fromMaybe W $ b (i-1) j
      in  toTile centre above right below left

-- order is: centre, above, right, below, left
toTile :: BasicTile -> BasicTile -> BasicTile -> BasicTile -> BasicTile ->
          Either String Tile
toTile W _ _ _ _ = return Inaccessible
toTile E E E E E = return Intersection
toTile E W E E E = return TeeJunctionDown
toTile E E W E E = return TeeJunctionLeft
toTile E E E W E = return TeeJunctionUp
toTile E E E E W = return TeeJunctionRight
toTile E W W E E = return CornerDownLeft
toTile E W E W E = return StraightHorizontal
toTile E W E E W = return CornerRightDown
toTile E E W W E = return CornerLeftUp
toTile E E W E W = return StraightVertical
toTile E E E W W = return CornerUpRight
toTile E _ _ _ _ = fail "dead ends are not supported"

basicMap2 :: LevelMap
basicMap2 =
  fromJust $ mkLevelMap $ either error id $ fromString $
  """
  #################
  #_______________#
  #_##_##_####_##_#
  #_____#___#_____#
  #_###_###___###_#
  #_______________#
  ##_##_##_###_####
  ##_##_#___##___##
  #_____#___####_##
  #_#_#_#####____##
  #_#_#_______##_##
  #_____###_#_____#
  ##_##___#_#_###_#
  #_____#___#_____#
  #_######_###_##_#
  #_______________#
  #################
  """

mkLevelMap :: [[Tile]] -> Maybe LevelMap
mkLevelMap ts = fmap (\bs -> { blocks: bs, tiles: ts }) (concatTiles ts)

basicMap :: LevelMap
basicMap = fromJust (mkLevelMap basicTileMap)

getBlockAt :: Position -> LevelMap -> Maybe Block
getBlockAt (Position pos) levelmap =
  levelmap.blocks !! pos.x >>= (\r -> r !! pos.y)

module LevelMap where

import Data.Either
import Data.Tuple
import Data.Char (charString)
import Data.String (split, trim, toCharArray, joinWith)
import Control.Lens ((~))
import Control.Monad (unless)
import Math (floor)
import Data.Array (map, filter, null, reverse, (!!), range, concatMap,
                   concat, length)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Traversable (for, sequence)
import Data.Foldable (mconcat, all)

import Utils
import Types hiding (Direction(..))

-- the number of tiles along one side of a level map.
tilesAlongSide :: Number
tilesAlongSide = 17

-- the height or width in a level, in blocks.
mapSize :: Number
mapSize = tileSize * tilesAlongSide

normalize :: Tile -> Tuple Number Tile
normalize t =
  case t of
    Intersection       -> (0 ~ Intersection)
    TeeJunctionUp      -> (0 ~ TeeJunctionUp)
    TeeJunctionRight   -> (1 ~ TeeJunctionUp)
    TeeJunctionDown    -> (2 ~ TeeJunctionUp)
    TeeJunctionLeft    -> (3 ~ TeeJunctionUp)
    CornerUpRight      -> (0 ~ CornerUpRight)
    CornerRightDown    -> (1 ~ CornerUpRight)
    CornerDownLeft     -> (2 ~ CornerUpRight)
    CornerLeftUp       -> (3 ~ CornerUpRight)
    StraightHorizontal -> (0 ~ StraightHorizontal)
    StraightVertical   -> (1 ~ StraightHorizontal)
    Inaccessible       -> (0 ~ Inaccessible)

toBlockTile :: Tile -> BlockTile
toBlockTile t =
  case normalize t of
    Tuple n t' -> applyN n rotateCW (convert t')
  where
  convert t =
    case t of
      Intersection       -> intersectionB
      TeeJunctionUp      -> teeJunctionUpB
      CornerUpRight      -> cornerUpRightB
      StraightHorizontal -> straightHorizontalB
      Inaccessible       -> inaccessibleB

mkBlockTile :: BlockTile -> BlockTile
mkBlockTile b =
  let rightLength :: forall a. [a] -> Boolean
      rightLength x = length x == tileSize
      ok = rightLength b && all rightLength b
  in  if ok then b else error "bad dimensions for BlockTile"

rotateCW :: BlockTile -> BlockTile
rotateCW = map reverse >>> transpose

debugShowBlockTile :: BlockTile -> String
debugShowBlockTile bt =
  let rows = transpose bt
      showRow = map showBlock >>> joinWith ""
      showBlock b =
        case b of
          Wall -> "#"
          Empty -> " "
  in  joinWith "\n" (map showRow rows)

concatTiles :: [[Tile]] -> Maybe [[Block]]
concatTiles =
  map (map toBlockTile) >>> map concatTileRow >>> sequence >>> fmap concat

concatTileRow :: [BlockTile] -> Maybe [[Block]]
concatTileRow ts =
    let r = range 0 (tileSize - 1)
        getRow n t = t !! n
        getRowComponents n = map (getRow n) ts
        maybes = map (getRowComponents >>> mconcat) r
    in  sequence maybes

-- The number of blocks along one side of a tile in the level map. This allows
-- a simpler model, since any given object may exist in only one block.
-- Should be an odd number, since any tile should have one central block.
tileSize :: Number
tileSize = 11

halfTile :: Number
halfTile = floor (tileSize / 2)

mirror :: forall a. a -> a -> [a]
mirror x y =
    let xs = replicate halfTile x
    in xs <> [y] <> xs

intersectionB :: BlockTile
intersectionB =
    let normalRow = mirror Wall Empty
        centralRow = replicate tileSize Empty
    in mkBlockTile $ mirror normalRow centralRow

teeJunctionUpB :: BlockTile
teeJunctionUpB =
    let normalCol  = mirror Wall Empty
        centralCol = replicate halfTile Empty <>
                        [Empty] <>
                        replicate halfTile Wall
    in  mkBlockTile $ mirror normalCol centralCol

cornerUpRightB :: BlockTile
cornerUpRightB =
    let upperRow = mirror Wall Empty
        centralRow = replicate halfTile Wall <> replicate (halfTile + 1) Empty
        lowerRow = replicate tileSize Wall
        byRows =
          replicate halfTile upperRow <>
              [centralRow] <>
              replicate halfTile lowerRow
    in  mkBlockTile $ transpose byRows

straightHorizontalB :: BlockTile
straightHorizontalB =
  let col = mirror Wall Empty
  in  mkBlockTile $ replicate tileSize col

inaccessibleB :: BlockTile
inaccessibleB = mkBlockTile $ replicate tileSize (replicate tileSize Wall)

basicTileMap :: [[Tile]]
basicTileMap =
    let n = tilesAlongSide - 2
        leftCol =
            [CornerRightDown] <>
                replicate n TeeJunctionDown <>
                [CornerUpRight]
        centralCol =
            [TeeJunctionDown] <>
                replicate n Intersection <>
                [TeeJunctionUp]
        rightCol =
            [CornerDownLeft] <>
                replicate n TeeJunctionUp <>
                [CornerLeftUp]
    in [leftCol] <> replicate n centralCol <> [rightCol]

fromString :: String -> Either String [[Tile]]
fromString str = parseLevelMapString str >>= constructLevelMap

-- 'Wall' or 'Empty'
data BasicTile = W | E

fail = Left

parseLevelMapString :: String -> Either String [[BasicTile]]
parseLevelMapString str = do
  let toLines =
    split "\n" >>>
      map (trim >>> toCharArray) >>>
      filter (not <<< null) >>>
      transpose

  let lines = toLines str
  unless (rightLength lines && all rightLength lines) $
    fail $ "expected a square levelmap; dimensions should be " <>
            show tilesAlongSide <> " by " <> show tilesAlongSide

  for lines $ \line ->
    for line $ \char ->
      let c = charString char
      in case c of
        "#" -> return W
        "_" -> return E
        _   -> fail $ "unexpected char '" <> c <> "'; expected '#' or '_'"

  where
  rightLength :: forall a. [a] -> Boolean
  rightLength x = length x == tilesAlongSide

constructLevelMap :: [[BasicTile]] -> Either String [[Tile]]
constructLevelMap basicTiles = do
  let tileIndices = range 0 (tilesAlongSide - 1)
  let b i j = basicTiles !! i >>= (\r -> r !! j)

  for tileIndices $ \i ->
    for tileIndices $ \j ->
      let centre = fromJust $ b i j
          above = fromMaybe W $ b i (j-1)
          below = fromMaybe W $ b i (j+1)
          right = fromMaybe W $ b (i+1) j
          left  = fromMaybe W $ b (i-1) j
      in  toTile centre above right below left

-- order is: centre, above, right, below, left
toTile :: BasicTile -> BasicTile -> BasicTile -> BasicTile -> BasicTile ->
          Either String Tile
toTile W _ _ _ _ = return Inaccessible
toTile E E E E E = return Intersection
toTile E W E E E = return TeeJunctionDown
toTile E E W E E = return TeeJunctionLeft
toTile E E E W E = return TeeJunctionUp
toTile E E E E W = return TeeJunctionRight
toTile E W W E E = return CornerDownLeft
toTile E W E W E = return StraightHorizontal
toTile E W E E W = return CornerRightDown
toTile E E W W E = return CornerLeftUp
toTile E E W E W = return StraightVertical
toTile E E E W W = return CornerUpRight
toTile E _ _ _ _ = fail "dead ends are not supported"

basicMap2 :: LevelMap
basicMap2 =
  fromJust $ mkLevelMap $ either error id $ fromString $
  """
  #################
  #_______________#
  #_##_###_###_##_#
  #_____#___#_____#
  ##_##___#___##_##
  #_____#_#_#_____#
  #_##_##___##_##_#
  #_##____#____##_#
  #____##___##____#
  #_##____#____##_#
  #_##_##___##_##_#
  #_____#_#_#_____#
  ##_##___#___##_##
  #_____#___#_____#
  #_##_###_###_##_#
  #_______________#
  #################
  """

basicMap3 :: LevelMap
basicMap3 =
  fromJust $ mkLevelMap (replicate tilesAlongSide
                (replicate tilesAlongSide TeeJunctionLeft))

mkLevelMap :: [[Tile]] -> Maybe LevelMap
mkLevelMap ts = fmap (\bs -> { blocks: bs, tiles: ts }) (concatTiles ts)

basicMap :: LevelMap
basicMap = fromJust (mkLevelMap basicTileMap)

getBlockAt :: Position -> LevelMap -> Maybe Block
getBlockAt (Position pos) levelmap =
  levelmap.blocks !! pos.x >>= (\r -> r !! pos.y)