Bump gene track by comparing GWAS data to Genes data

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, maximum)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.List (List(..))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF, unwrap)
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Semigroup.Foldable (foldMap1)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse)
import Data.Tuple (Tuple(Tuple), fst, snd, uncurry)
import Data.Unfoldable (class Unfoldable, singleton)
import Data.Unfoldable as Unfoldable
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.
type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

tagRenderer :: forall a sym r1 r2.
               RowCons sym a r1 r2
            => IsSymbol sym
            => SProxy sym
            -> PureRenderer a
            -> PureRenderer (Variant r2)
tagRenderer sym renderer var = Variant.prj sym var >>= renderer

combineRenderers :: forall r1 r2 r3.
                    Union r1 r2 r3
                 => Contractable r3 r1
                 => Contractable r3 r2
                 => PureRenderer (Variant r1)
                 -> PureRenderer (Variant r2)
                 -> PureRenderer (Variant r3)
combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
                             (Variant.contract var >>= r2)

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

-- A single Frame that contains all data that is required to draw it
type ReadyFrame a = { width :: Pixels
                    , padding :: Pixels
                    , height :: Pixels
                    , contents :: a }

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o d -> translate o 0.0 d) os drawings'
  where os = Array.cons 0.0 (framesOffsets $ snd <$> frames) -- add 0.0 since scanl in framesOffsets doesn't include seed
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall f r.
                 Traversable f
              => f { width :: Pixels | r }
              -> f Pixels
framesOffsets fs = scanl (\o {width} -> width + o) 0.0 fs

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

createFrames :: forall r a.
                RowLacks "frame" (size :: Bp | r)
             => Pixels
             -> Pixels
             -> Map ChrId {size :: Bp | r}
             -> Map ChrId a
             -> Map ChrId { size :: Bp, frame :: Frame a | r }
createFrames totalWidth padding sizes as = zipMapsWith zippy sizes as
  where ts = totalSize sizes
        mkWidth size = (unwrap $ size / ts) * totalWidth
        mkFrame' {size} a = { padding, width: mkWidth size, contents: a }
        zippy r a = insertFrame (mkFrame' r a) r

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add :: { chrId :: ChrId | rData } -> Maybe _ -> Maybe _
        add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

chrFrames :: forall a.
             _
          -> Pixels
          -> Pixels
          -> Map ChrId a
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       }
chrFrames ctx w p as = createFrames w p chrCtx' as
  where chrCtx' = Map.filterKeys (\k -> k `Map.member` as) ctx

mouseChrFrames = chrFrames mouseChrCtx

addHeight :: forall a r.
             Pixels
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       | r
                       }
          -> Map ChrId { size :: Bp
                       , frame :: (ReadyFrame a)
                       | r }
addHeight h fs = map f fs
  where f entry = entry { frame = Record.insert (SProxy :: SProxy "height") h entry.frame }

fetchJSON :: forall a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON :: String -> Aff _ (Array (GWASFeature ()))
fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow' r = ( geneID :: String
                  , desc :: String
                  , start :: Bp
                  , end :: Bp
                  , name :: String | r )

type Gene' r = Record (GeneRow' r)

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

gene'JSONParse :: Json -> Maybe (Gene' ())
gene'JSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  pure {geneID, desc, name, start, end}

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String
  pure {geneID, desc, name, start, end, chrId}

fetchGene'JSON :: String -> Aff _ (Array (Gene' ()))
fetchGene'JSON = fetchJSON gene'JSONParse

geneFetchChrId :: forall r.
                  RowLacks "chrId" (GeneRow' r)
               => Gene' r
               -> Aff _ (Gene r)
geneFetchChrId gene = do
  let url = "http://rest.ensembl.org/lookup/id/" <>
            gene.geneID <> "?content-type=application/json"

  res <- _.response <$> Affjax.get url

  let chrId :: _
      chrId = do
        obj <- res ^? _Object
        ChrId <$> obj ^? ix "seq_region_name" <<< _String

  case chrId of
    Nothing  -> throwError $ error $ "Could not find chrId for gene " <> gene.geneID
    Just chr -> pure $ Record.insert (SProxy :: SProxy "chrId") chr gene

fetchGeneJSONEnsembl :: String -> Aff _ (Array (Gene ()))
fetchGeneJSONEnsembl url = traverse geneFetchChrId =<< fetchJSON gene'JSONParse url

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

mkGeneRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp | rctx)) m
               => m (PureRenderer (Gene rf))
mkGeneRenderer = do
  ctx <- ask

  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        let rad = 20.0
            lHand = unwrap $ f.start / size
            rHand = unwrap $ f.end / size
            w = (rHand - lHand) * unwrap size
            x = lHand + (rHand - lHand)
            y = 0.5
            rect = rectangle lHand (y - rad/2.0) w (rad/2.0)
            out = outlined (outlineColor red) rect
            fill = filled (fillColor maroon) rect
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' x (y-0.25) (fillColor black) f.desc
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number }
                   -> PureRenderer (Record rf)
                   -> PureRenderer (Record (minY :: Number | rf))
shiftRendererMinY dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "minY") f)
  let {x,y} = unwrap point
      normY = (s.max - f.minY) / (s.max - s.min)
      y' = min (y + normY - dist) 1.0
  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

bumpedGeneRenderer :: forall rf.
                      RowLacks "minY" (GeneRow rf)
                   => { min :: Number, max :: Number }
                   -> PureRenderer (Gene rf)
                   -> PureRenderer (Gene (minY :: Number | rf))
bumpedGeneRenderer s = shiftRendererMinY 0.05 s

bumpGenes :: forall rGene rGWAS.
             RowLacks "minY" (GeneRow rGene)
          => Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Gene rGene))
          -> Map ChrId (List (Gene (minY :: Number | rGene)))
bumpGenes = zipMapsWith (map <<< bumpGene)
  where maxScoreIn :: Bp -> Bp -> List (GWASFeature rGWAS) -> Number
        maxScoreIn l r gwas = fromMaybe 0.5 $ maximum
                              $ map (\g -> if g.pos >= l && g.pos <= r
                                           then g.score else 0.0) gwas
        bumpGene :: List (GWASFeature rGWAS) -> Gene rGene -> Gene (minY :: Number | rGene)
        bumpGene l g = let minY = maxScoreIn g.start g.end l
                       in Record.insert (SProxy :: SProxy "minY") minY g

drawData :: forall f a.
            Foldable f
         => { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData {w,h,p,y} renderer dat chrs =
  let features :: Map ChrId (Array a)
      features = map Array.fromFoldable
                 $ Map.filterKeys (\k -> k `Array.elem` chrs) dat

      readyFrames :: Map ChrId { size :: Bp, frame :: ReadyFrame (Array a) }
      readyFrames = addHeight h $ mouseChrFrames w p features

      toDraw :: Array (ReadyFrame (Array a))
      toDraw = _.frame  <$> (filterMap (\chr -> Map.lookup chr readyFrames) chrs)

  in translate 0.0 (h-y) $ scale 1.0 (-1.0) $ drawFrames toDraw renderer

{-
drawGenes :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> List (Gene r)
          -> Array ChrId
          -> Drawing
drawGenes pos dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where renderer = mkGeneRenderer mouseChrCtx

drawGemma :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> { min :: Number, max :: Number }
          -> List (GWASFeature r)
          -> Array ChrId
          -> Drawing
drawGemma pos s dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer :: PureRenderer (GWASFeature r)
        renderer = mkGwasRenderer s colorsCtx

drawBoth :: forall r.
            { w :: Number, h :: Number
            , p :: Number, y :: Number }
         -> { min :: Number, max :: Number }
         -> Map ChrId (List (Variant ("Gene" :: Gene (), "GWAS" :: GWASFeature ())))
         -> Array ChrId
         -> Drawing
drawBoth pos s dat chrs = drawData pos renderer dat chrs
  where geneR :: PureRenderer (Variant ("Gene" :: Gene ()))
        geneR = tagRenderer (SProxy :: SProxy "Gene") $ mkGeneRenderer mouseChrCtx
        gemmaR :: PureRenderer (Variant ("GWAS" :: GWASFeature ()))
        gemmaR = tagRenderer (SProxy :: SProxy "GWAS") $ mkGwasRenderer s colorsCtx
        colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer = combineRenderers geneR gemmaR
-}

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
              [ navy, blue, aqua, teal, olive
              , green, lime, yellow, orange, red
              , maroon, fuchsia, purple, navy, blue
              , aqua, teal, olive, green, lime
              , yellow ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.List (List(..))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, alaF, unwrap)
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (singleton)
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.
type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

tagRenderer :: forall a sym r1 r2.
               RowCons sym a r1 r2
            => IsSymbol sym
            => SProxy sym
            -> PureRenderer a
            -> PureRenderer (Variant r2)
tagRenderer sym renderer var = do
  feature <- Variant.prj sym var
  renderer feature

combineRenderers :: forall r1 r2 r3.
                    Union r1 r2 r3
                 => Contractable r3 r1
                 => Contractable r3 r2
                 => PureRenderer (Variant r1)
                 -> PureRenderer (Variant r2)
                 -> PureRenderer (Variant r3)
combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
                             (Variant.contract var >>= r2)

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

-- A single Frame that contains all data that is required to draw it
type ReadyFrame a = { width :: Pixels
                    , padding :: Pixels
                    , height :: Pixels
                    , contents :: a }

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o d -> translate o 0.0 d) os drawings'
  where os = Array.cons 0.0 (framesOffsets $ snd <$> frames) -- add 0.0 since scanl in framesOffsets doesn't include seed
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall f r.
                 Traversable f
              => f { width :: Pixels | r }
              -> f Pixels
framesOffsets fs = scanl (\o {width} -> width + o) 0.0 fs

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

createFrames :: forall r a.
                RowLacks "frame" (size :: Bp | r)
             => Pixels
             -> Pixels
             -> Map ChrId {size :: Bp | r}
             -> Map ChrId a
             -> Map ChrId { size :: Bp, frame :: Frame a | r }
createFrames totalWidth padding sizes as = zipMapsWith zippy sizes as
  where ts = totalSize sizes
        mkWidth size = (unwrap $ size / ts) * totalWidth
        mkFrame' {size} a = { padding, width: mkWidth size, contents: a }
        zippy r a = insertFrame (mkFrame' r a) r

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add :: { chrId :: ChrId | rData } -> Maybe _ -> Maybe _
        add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

chrFrames :: forall a.
             _
          -> Pixels
          -> Pixels
          -> Map ChrId a
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       }
chrFrames ctx w p as = createFrames w p chrCtx' as
  where chrCtx' = Map.filterKeys (\k -> k `Map.member` as) ctx

mouseChrFrames = chrFrames mouseChrCtx

addHeight :: forall a r.
             Pixels
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       | r
                       }
          -> Map ChrId { size :: Bp
                       , frame :: (ReadyFrame a)
                       | r }
addHeight h fs = map f fs
  where f entry = entry { frame = Record.insert (SProxy :: SProxy "height") h entry.frame }

fetchJSON :: forall a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow' r = ( geneID :: String
                  , desc :: String
                  , start :: Bp
                  , end :: Bp
                  , name :: String | r )

type Gene' r = Record (GeneRow' r)

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

gene'JSONParse :: Json -> Maybe (Gene' ())
gene'JSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  pure {geneID, desc, name, start, end}

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String
  pure {geneID, desc, name, start, end, chrId}

fetchGene'JSON :: String -> Aff _ (Array (Gene' ()))
fetchGene'JSON = fetchJSON gene'JSONParse

geneFetchChrId :: forall r.
                  RowLacks "chrId" (GeneRow' r)
               => Gene' r
               -> Aff _ (Gene r)
geneFetchChrId gene = do
  let url = "http://rest.ensembl.org/lookup/id/" <>
            gene.geneID <> "?content-type=application/json"

  res <- _.response <$> Affjax.get url

  let chrId :: _
      chrId = do
        obj <- res ^? _Object
        ChrId <$> obj ^? ix "seq_region_name" <<< _String

  case chrId of
    Nothing  -> throwError $ error $ "Could not find chrId for gene " <> gene.geneID
    Just chr -> pure $ Record.insert (SProxy :: SProxy "chrId") chr gene

fetchGeneJSONEnsembl :: String -> Aff _ (Array (Gene ()))
fetchGeneJSONEnsembl url = traverse geneFetchChrId =<< fetchJSON gene'JSONParse url

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

mkGeneRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp | rctx)) m
               => m (PureRenderer (Gene rf))
mkGeneRenderer = do
  ctx <- ask

  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        let rad = 20.0
            lHand = unwrap $ f.start / size
            rHand = unwrap $ f.end / size
            w = (rHand - lHand) * unwrap size
            x = lHand + (rHand - lHand)
            y = 0.5
            rect = rectangle lHand (y - rad/2.0) w (rad/2.0)
            out = outlined (outlineColor red) rect
            fill = filled (fillColor maroon) rect
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' x (y-0.25) (fillColor black) f.desc
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

shiftRendererScore :: forall rf.
                          RowLacks "score" rf
                       => Number
                       -> { min :: Number, max :: Number }
                       -> PureRenderer (Record rf)
                       -> PureRenderer (Record (score :: Number | rf))
shiftRendererScore dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "score") f)
  let {x,y} = unwrap point
      y' = min (y + f.score - dist) 1.0
  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

findRenderer :: forall a.
                Map String (PureRenderer a)
             -> PureRenderer (Tuple String a)
findRenderer rs (Tuple s a) = do
  renderer <- Map.lookup s rs
  renderer a

drawData :: forall f a.
            Foldable f
         => { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData {w,h,p,y} renderer dat chrs =
  let features :: Map ChrId (Array a)
      features = map Array.fromFoldable
                 $ Map.filterKeys (\k -> k `Array.elem` chrs) dat

      readyFrames :: Map ChrId { size :: Bp, frame :: ReadyFrame (Array a) }
      readyFrames = addHeight h $ mouseChrFrames w p features

      toDraw :: Array (ReadyFrame (Array a))
      toDraw = _.frame  <$> (filterMap (\chr -> Map.lookup chr readyFrames) chrs)

  in translate 0.0 (h-y) $ scale 1.0 (-1.0) $ drawFrames toDraw renderer

{-
drawGenes :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> List (Gene r)
          -> Array ChrId
          -> Drawing
drawGenes pos dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where renderer = mkGeneRenderer mouseChrCtx

drawGemma :: forall r.
             { w :: Number, h :: Number
             , p :: Number, y :: Number }
          -> { min :: Number, max :: Number }
          -> List (GWASFeature r)
          -> Array ChrId
          -> Drawing
drawGemma pos s dat chrs = drawData pos renderer (groupToChrs dat) chrs
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer :: PureRenderer (GWASFeature r)
        renderer = mkGwasRenderer s colorsCtx

drawBoth :: forall r.
            { w :: Number, h :: Number
            , p :: Number, y :: Number }
         -> { min :: Number, max :: Number }
         -> Map ChrId (List (Variant ("Gene" :: Gene (), "GWAS" :: GWASFeature ())))
         -> Array ChrId
         -> Drawing
drawBoth pos s dat chrs = drawData pos renderer dat chrs
  where geneR :: PureRenderer (Variant ("Gene" :: Gene ()))
        geneR = tagRenderer (SProxy :: SProxy "Gene") $ mkGeneRenderer mouseChrCtx
        gemmaR :: PureRenderer (Variant ("GWAS" :: GWASFeature ()))
        gemmaR = tagRenderer (SProxy :: SProxy "GWAS") $ mkGwasRenderer s colorsCtx
        colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                    mouseChrCtx mouseColors
        renderer = combineRenderers geneR gemmaR
-}

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
              [ navy, blue, aqua, teal, olive
              , green, lime, yellow, orange, red
              , maroon, fuchsia, purple, navy, blue
              , aqua, teal, olive, green, lime
              , yellow ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs


Add never Aff.

Add never Aff.

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , BracketConditions
  , makeAff
  , launchAff
  , launchSuspendedAff
  , runAff
  , runAff_
  , forkAff
  , suspendAff
  , spawnAff
  , spawnSuspendedAff
  , liftEff'
  , bracket
  , generalBracket
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , module Exports
  ) where

import Prelude
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..), isLeft)
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

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

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

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

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

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

instance plusAff ∷ Plus (Aff eff) 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 eff) 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 eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

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

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

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

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

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

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff 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 eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

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

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { kill ∷ Error → Aff eff Unit
  , join ∷ Aff eff a
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = Fiber
    { kill: const (pure unit)
    , join: memoAff (f <$> joinFiber t)
    }

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = Fiber
    { kill: const (pure unit)
    , join: memoAff (joinFiber t1 <*> joinFiber t2)
    }

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = Fiber
    { kill: const (pure unit)
    , join: pure a
    }

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = t.kill e

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = t.join

-- | 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 eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) 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 eff) where
  mempty = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = Fn.runFn3 _launchAff ffiUtil false aff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff aff = Fn.runFn3 _launchAff ffiUtil true aff

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

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

-- | Forks a supervised `Aff` from within a parent `Aff` context, returning the
-- | `Fiber`. When the parent `Fiber` completes, the child will be killed if it
-- | has not completed.
forkAff ∷ ∀  eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork false

-- | Suspends a supervised `Aff` from within a parent `Aff` context, returning
-- | the `Fiber`. A suspended `Fiber` does not execute until requested, via
-- | `joinFiber`.
suspendAff ∷ ∀  eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork true

-- | Forks an unsupervised `Aff`, returning the `Fiber`.
spawnAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
spawnAff = liftEff <<< launchAff

-- | Suspends an unsupervised `Aff`, returning the `Fiber`.
spawnSuspendedAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
spawnSuspendedAff = liftEff <<< launchSuspendedAff

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

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

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

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

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

-- | 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 ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed
    }

foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a

type BracketConditions eff a =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ a → Aff eff 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 ∷ ∀ eff a b. Aff eff a → BracketConditions eff a → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` 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 ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

-- | Do not export this function. It is not referentially transparent in
-- | general, and can be used to create global mutable references.
foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a

foreign import _launchAff
  ∷ ∀ eff a
  . Fn.Fn3
      FFIUtil
      Boolean
      (Aff eff a)
      (Eff eff (Fiber eff a))

foreign import _sequential
  ∷ ∀ eff a
  . Fn.Fn2
      FFIUtil
      (ParAff eff a)
      (Aff eff a)

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
  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 Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , BracketConditions
  , makeAff
  , launchAff
  , launchSuspendedAff
  , runAff
  , runAff_
  , forkAff
  , suspendAff
  , spawnAff
  , spawnSuspendedAff
  , liftEff'
  , bracket
  , generalBracket
  , delay
  , finally
  , atomically
  , killFiber
  , joinFiber
  , module Exports
  ) where

import Prelude
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..), isLeft)
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

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

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

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

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

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

instance plusAff ∷ Plus (Aff eff) 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 eff) 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 eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

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

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

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

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

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

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff 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 eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

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

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { kill ∷ Error → Aff eff Unit
  , join ∷ Aff eff a
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = Fiber
    { kill: const (pure unit)
    , join: memoAff (f <$> joinFiber t)
    }

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = Fiber
    { kill: const (pure unit)
    , join: memoAff (joinFiber t1 <*> joinFiber t2)
    }

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = Fiber
    { kill: const (pure unit)
    , join: pure a
    }

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = t.kill e

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = t.join

-- | 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 eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) 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 eff) where
  mempty = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = Fn.runFn3 _launchAff ffiUtil false aff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff aff = Fn.runFn3 _launchAff ffiUtil true aff

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

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

-- | Forks a supervised `Aff` from within a parent `Aff` context, returning the
-- | `Fiber`. When the parent `Fiber` completes, the child will be killed if it
-- | has not completed.
forkAff ∷ ∀  eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork false

-- | Suspends a supervised `Aff` from within a parent `Aff` context, returning
-- | the `Fiber`. A suspended `Fiber` does not execute until requested, via
-- | `joinFiber`.
suspendAff ∷ ∀  eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork true

-- | Forks an unsupervised `Aff`, returning the `Fiber`.
spawnAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
spawnAff = liftEff <<< launchAff

-- | Suspends an unsupervised `Aff`, returning the `Fiber`.
spawnSuspendedAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
spawnSuspendedAff = liftEff <<< launchSuspendedAff

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

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

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

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

-- | 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 ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed
    }

foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a

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

-- | A general purpose bracket
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` 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 ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

-- | Do not export this function. It is not referentially transparent in
-- | general, and can be used to create global mutable references.
foreign import memoAff ∷ ∀ eff a. Aff eff a → Aff eff a

foreign import _launchAff
  ∷ ∀ eff a
  . Fn.Fn3
      FFIUtil
      Boolean
      (Aff eff a)
      (Eff eff (Fiber eff a))

foreign import _sequential
  ∷ ∀ eff a
  . Fn.Fn2
      FFIUtil
      (ParAff eff a)
      (Aff eff a)

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


take effects off map ctor function

take effects off map ctor function

couldn’t work out how to avoid double wrapping of effects doing this so taking it out just to make progress and will revisit

also reverted the Maybe on the optional function parameter for same reasons of general monadic confuzzlement

module D3.Collections.Map
  ( d3MapFn
  , D3Map
  , D3MapKey
  -- , D3MapValue
  , D3KeyValue
  , D3KVFn
  , d3Map
  , d3MapF
  , d3mapGetFn
  , d3mapSetFn
  , d3mapHasFn
  , d3mapRemoveFn
  , d3mapClearFn
  , d3mapKeysFn
  , d3mapValuesFn
  , d3mapEntriesFn
  , d3mapSizeFn
  , d3mapEmptyFn
  , d3mapEachFn
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import D3.Base (D3)
import Data.Function.Eff (EffFn2, EffFn1, runEffFn1, runEffFn2)

foreign import data D3Map :: * -> *

type D3MapKey     = String
-- type D3MapValue   = Void -- d3Maps can have varying types in one map
type D3KeyValue d  = { key :: D3MapKey, value :: d }
type D3KVFn       = ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey d Unit
-- type D3MakeKeysEffFn d = ∀ eff. EffFn1 (d3::D3|eff) d          D3MapKey
-- type D3MakeKeysFn d    = ∀ eff. d          -> Eff (d3::D3|eff) D3MapKey
--
-- test :: ∀ d eff. D3MakeKeysFn d -> D3MakeKeysEffFn d
-- test = mkEffFn1
--
-- test' :: ∀ d eff. D3MakeKeysEffFn d -> D3MakeKeysFn d
-- test' = runEffFn1

-- | Constructor for a D3Map that takes a collection and tries to make Map from it
-- | since this can fail it would be good to add EXCEPTION here and return EITHER - TODO
foreign import d3MapFn        :: ∀ c d eff. EffFn1 (d3::D3|eff) c                (D3Map d)
foreign import d3MapFnFn      :: ∀ c d eff. EffFn2 (d3::D3|eff)
                                                    c
                                                    (d -> D3MapKey) -- function passed in
                                                    (D3Map d)

-- | Constructor for a D3Map that takes a collection and a function to produce keys from the data
-- foreign import d3MapFnFn      :: ∀ c d eff. EffFn2 (d3::D3|eff) c  (D3MakeKeysEffFn d)  (D3Map d)

-- | Functions available on D3Maps, similar but not same to ES5 Maps
foreign import d3mapClearFn   :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (D3Map d)
foreign import d3mapEmptyFn   :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          Boolean
foreign import d3mapEntriesFn :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (Array (D3KeyValue d))
foreign import d3mapGetFn     :: ∀ d eff. EffFn1 (d3::D3|eff) D3MapKey           d
foreign import d3mapKeysFn    :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (Array D3MapKey)
foreign import d3mapSizeFn    :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          Number
foreign import d3mapValuesFn  :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (Array d)
foreign import d3mapHasFn     :: ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey (D3Map d) Boolean
foreign import d3mapRemoveFn  :: ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey (D3Map d) (D3Map d)
foreign import d3mapEachFn    :: ∀ d eff. EffFn2 (d3::D3|eff) D3KVFn   (D3Map d) (D3Map d)
foreign import d3mapSetFn     :: ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey    d      (D3Map d)

-- | Purescript constructor for D3Map
-- Lot of type unsafety here - we're giving the D3 map constructor a type c and claiming it
-- gives us back a Map of type d, assumes c is a valid homomorphous collection of d's
d3Map :: ∀ c d eff. c -> Eff (d3::D3|eff) (D3Map d)
d3Map c  = runEffFn1 d3MapFn c
-- | Also, this callback does potentially add real overhead since it's called
-- for all elements of the map but it's gotta be done this way if you're going
-- to pass in a Purescript lambda (maybe you could add a third variation that
-- takes an FFI function instead of passing Lambda)
d3MapF :: ∀ c d eff. c -> (d -> D3MapKey) -> Eff (d3::D3|eff) (D3Map d)
d3MapF c f = runEffFn2 d3MapFnFn c f

-- | Functions available on D3Maps, similar but not same to ES5 Maps
d3mapClear   :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (D3Map d)
d3mapClear = runEffFn1 d3mapClearFn

d3mapEach    :: ∀ d eff. D3KVFn -> (D3Map d)        -> Eff (d3::D3|eff) (D3Map d)
d3mapEach = runEffFn2 d3mapEachFn

d3mapEmpty   :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) Boolean
d3mapEmpty = runEffFn1 d3mapEmptyFn

d3mapEntries :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (Array (D3KeyValue d))
d3mapEntries = runEffFn1 d3mapEntriesFn

d3mapGet     :: ∀ d eff. D3MapKey                   -> Eff (d3::D3|eff)  d
d3mapGet = runEffFn1 d3mapGetFn

d3mapHas     :: ∀ d eff. D3MapKey -> (D3Map d)      -> Eff (d3::D3|eff) Boolean
d3mapHas = runEffFn2 d3mapHasFn

d3mapKeys    :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (Array D3MapKey)
d3mapKeys = runEffFn1 d3mapKeysFn

d3mapRemove  :: ∀ d eff. D3MapKey -> (D3Map d)      -> Eff (d3::D3|eff) (D3Map d)
d3mapRemove = runEffFn2 d3mapRemoveFn

d3mapSet     :: ∀ d eff. D3MapKey -> d              -> Eff (d3::D3|eff) (D3Map d)
d3mapSet = runEffFn2 d3mapSetFn

d3mapSize    :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) Number
d3mapSize = runEffFn1 d3mapSizeFn

d3mapValues  :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (Array d)
d3mapValues = runEffFn1 d3mapValuesFn

module D3.Collections.Map
  ( d3MapFn
  , D3Map
  , D3MapKey
  -- , D3MapValue
  , D3KeyValue
  , D3KVFn
  , d3Map
  , d3mapGetFn
  , d3mapSetFn
  , d3mapHasFn
  , d3mapRemoveFn
  , d3mapClearFn
  , d3mapKeysFn
  , d3mapValuesFn
  , d3mapEntriesFn
  , d3mapSizeFn
  , d3mapEmptyFn
  , d3mapEachFn
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import D3.Base (D3)
import Data.Function.Eff (mkEffFn1, runEffFn2, runEffFn1, EffFn2, EffFn1)
import Data.Maybe (Maybe(Just, Nothing))

foreign import data D3Map :: * -> *

type D3MapKey     = String
-- type D3MapValue   = Void -- d3Maps can have varying types in one map
type D3KeyValue d  = { key :: D3MapKey, value :: d }
type D3KVFn       = ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey d Unit
-- type D3MakeKeysEffFn d = ∀ eff. EffFn1 (d3::D3|eff) d          D3MapKey
-- type D3MakeKeysFn d    = ∀ eff. d          -> Eff (d3::D3|eff) D3MapKey
--
-- test :: ∀ d eff. D3MakeKeysFn d -> D3MakeKeysEffFn d
-- test = mkEffFn1
--
-- test' :: ∀ d eff. D3MakeKeysEffFn d -> D3MakeKeysFn d
-- test' = runEffFn1

-- | Constructor for a D3Map that takes a collection and tries to make Map from it
-- | since this can fail it would be good to add EXCEPTION here and return EITHER - TODO
foreign import d3MapFn        :: ∀ c d eff. EffFn1 (d3::D3|eff) c                (D3Map d)
foreign import d3MapFnFn      :: ∀ c d eff. EffFn2 (d3::D3|eff)
                                                    c
                                                    (EffFn1 (d3::D3|eff) d D3MapKey) -- function passed in
                                                    (D3Map d)

-- | Constructor for a D3Map that takes a collection and a function to produce keys from the data
-- foreign import d3MapFnFn      :: ∀ c d eff. EffFn2 (d3::D3|eff) c  (D3MakeKeysEffFn d)  (D3Map d)

-- | Functions available on D3Maps, similar but not same to ES5 Maps
foreign import d3mapClearFn   :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (D3Map d)
foreign import d3mapEmptyFn   :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          Boolean
foreign import d3mapEntriesFn :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (Array (D3KeyValue d))
foreign import d3mapGetFn     :: ∀ d eff. EffFn1 (d3::D3|eff) D3MapKey           d
foreign import d3mapKeysFn    :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (Array D3MapKey)
foreign import d3mapSizeFn    :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          Number
foreign import d3mapValuesFn  :: ∀ d eff. EffFn1 (d3::D3|eff) (D3Map d)          (Array d)
foreign import d3mapHasFn     :: ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey (D3Map d) Boolean
foreign import d3mapRemoveFn  :: ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey (D3Map d) (D3Map d)
foreign import d3mapEachFn    :: ∀ d eff. EffFn2 (d3::D3|eff) D3KVFn   (D3Map d) (D3Map d)
foreign import d3mapSetFn     :: ∀ d eff. EffFn2 (d3::D3|eff) D3MapKey    d      (D3Map d)

-- | Purescript constructor for D3Map
-- Lot of type unsafety here - we're giving the D3 map constructor a type c and claiming it
-- gives us back a Map of type d, assumes c is a valid homomorphous collection of d's
d3Map :: ∀ c d eff. c -> Maybe (d -> Eff (d3::D3|eff) D3MapKey) -> Eff (d3::D3|eff) (D3Map d)
d3Map c Nothing  = runEffFn1 d3MapFn c
-- | Also, this callback does potentially add real overhead since it's called
-- for all elements of the map but it's gotta be done this way if you're going
-- to pass in a Purescript lambda (maybe you could add a third variation that
-- takes an FFI function instead of passing Lambda)
d3Map c (Just f) = runEffFn2 d3MapFnFn c (mkEffFn1 f)

-- | Functions available on D3Maps, similar but not same to ES5 Maps
d3mapClear   :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (D3Map d)
d3mapClear = runEffFn1 d3mapClearFn

d3mapEach    :: ∀ d eff. D3KVFn -> (D3Map d)        -> Eff (d3::D3|eff) (D3Map d)
d3mapEach = runEffFn2 d3mapEachFn

d3mapEmpty   :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) Boolean
d3mapEmpty = runEffFn1 d3mapEmptyFn

d3mapEntries :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (Array (D3KeyValue d))
d3mapEntries = runEffFn1 d3mapEntriesFn

d3mapGet     :: ∀ d eff. D3MapKey                   -> Eff (d3::D3|eff)  d
d3mapGet = runEffFn1 d3mapGetFn

d3mapHas     :: ∀ d eff. D3MapKey -> (D3Map d)      -> Eff (d3::D3|eff) Boolean
d3mapHas = runEffFn2 d3mapHasFn

d3mapKeys    :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (Array D3MapKey)
d3mapKeys = runEffFn1 d3mapKeysFn

d3mapRemove  :: ∀ d eff. D3MapKey -> (D3Map d)      -> Eff (d3::D3|eff) (D3Map d)
d3mapRemove = runEffFn2 d3mapRemoveFn

d3mapSet     :: ∀ d eff. D3MapKey -> d              -> Eff (d3::D3|eff) (D3Map d)
d3mapSet = runEffFn2 d3mapSetFn

d3mapSize    :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) Number
d3mapSize = runEffFn1 d3mapSizeFn

d3mapValues  :: ∀ d eff. (D3Map d)                  -> Eff (d3::D3|eff) (Array d)
d3mapValues = runEffFn1 d3mapValuesFn


Fixing the documentation.

Fixing the documentation.

-- | This module allows the creation of infinite lists in Purescript where you
-- | only pay the performance cost for each element in the infinite list when
-- | it is extracted.
-- |
-- | Every infinite list requires three different classes of functions:
-- |
-- | * Generators of infinite lists (iterate, repeat)
-- | * Manipulators of infinite lists (map, filter, zip, tail)
-- | * Getters of data from infinite lists (head, take, takeWhile)

module Data.InfiniteList
  ( InfiniteList
  , iterate
  , repeat
  , take
  , drop
  , takeWhile
  , dropWhile
  , head
  , tail
  , uncons
  , zip
  , zipWith
  , module Exports
  ) where

import Data.Array as A
import Data.Either as E
import Data.Filterable as F
import Data.Filterable (filter) as Exports
import Data.List as L
import Data.NonEmpty as NE
import Data.Function (id)
import Data.Functor (class Functor, map)
import Data.Maybe (Maybe(..), isJust, fromJust)
import Data.Tuple (Tuple(..), snd, uncurry)
import Partial.Unsafe (unsafePartialBecause)
import Prelude ((-), (+), ($), (<<<), (<=), otherwise)

-- | The datatype that represents an infinite list. The two type arguments are:
-- |
-- | * `a`: The type that will be returned by the getter methods.
-- | * `b`: The base type for this infinite list that is being iterated over.
data InfiniteList b a = IL (b -> a) (b -> b) b

-- Can't implement these classes
-- Eq: can't compare functions
-- Show: can't iterate the whole list...will let other people implement custom show methods
-- Ord: Requires Eq to be possible
-- Semigroup: Would be stupid ... since the lists are infinite xs <> ys => xs because you would never get to the elements of ys
-- Monoid: Infinite lists, by definition, cannot be empty. What would mempty be?
-- Foldable: You can't fold an infinite list
-- Traversable: You can't traverse the entirity of an infinite list
-- Alt: No, for the same reason as semigroup
-- Plus: Depends on Alt

instance infiniteFunctor :: Functor (InfiniteList a) where
  map f (IL conv iter start) = IL (f <<< conv) iter start

instance infiniteFilterable :: F.Filterable (InfiniteList a) where
  partitionMap = partitionMapInternal

  partition = partitionInternal

  filterMap = filterMapInternal

  filter = filterInternal

partitionMapInternal :: forall a b l r. (a -> E.Either l r) -> InfiniteList b a -> { left :: InfiniteList b l, right :: InfiniteList b r }
partitionMapInternal f il = {
    left: fromLeft applied,
    right: fromRight applied
  }
  where
    applied = map f il

fromLeft :: forall a b c. InfiniteList b (E.Either a c) -> InfiniteList b a
fromLeft = map (unsafePartialBecause "We have filtered on only the left elements" E.fromLeft) <<< filterInternal E.isLeft

fromRight :: forall a b c. InfiniteList b (E.Either c a) -> InfiniteList b a
fromRight = map (unsafePartialBecause "We have filtered on only the right elements" E.fromRight) <<< filterInternal E.isRight

partitionInternal :: forall a b. (a -> Boolean) -> InfiniteList b a -> { no :: InfiniteList b a, yes :: InfiniteList b a }
partitionInternal p xs = let o = partitionMapInternal (F.eitherBool p) xs
                         in {no: o.left, yes: o.right}

filterMapInternal :: forall a b c. (a -> Maybe c) -> InfiniteList b a -> InfiniteList b c
filterMapInternal f = catMaybes <<< map f

catMaybes :: forall b a. InfiniteList b (Maybe a) -> InfiniteList b a
catMaybes = map (unsafePartialBecause "We have filtered on only the Just elements" fromJust) <<< filterInternal isJust

filterInternal :: forall a b. (a -> Boolean) -> InfiniteList b a -> InfiniteList b a
filterInternal matches (IL conv iter start) = IL conv next nextStart
  where
    nextStart = if matches' start then start else next start

    next x = let step = iter x in
             if matches' step then step else next step

    matches' = matches <<< conv

-- We could possibly implement Apply if the need for it was there

-- | Generate an infinite list by providing:
-- |
-- |  * a function to iterate from the previous value in the infinite list to the next AND
-- |  * the first element in the infinite list to begin the iteration.
-- |
-- | For example, to generate the list of natural numbers you can do the following:
-- |
-- |     naturals = iterate ((+) 1) 1
-- |
-- | In english, "The natural numbers start at 1 and you can get the next natural
-- | number by adding one to the prior number".
-- |
-- | Running time: `O(1)`
iterate :: forall a. (a -> a) -> a -> InfiniteList a a
iterate iter start = IL id iter start

-- | Generate an infinite list by infinitely repeating a provided non-empty list.
-- |
-- | The list that is provided must be non-empty because it is impossible to repeat
-- | an empty list and end up with a list with something in it.
-- |
-- | To see how this method works see the following example:
-- |
-- |     > take 15 $ repeat (0 :| [2, 1, 3])
-- |     [0,2,1,3,0,2,1,3,0,2,1,3,0,2,1]
-- |
-- |     >
-- |
-- | This is an infinite repeat of the list 0, 2, 1, 3.
-- |
-- | Note: You will notice that an `InfiniteList (Tuple Int a) a` is returned, the
-- | reason for the tuple in the type is that the non-empty list that is passed in
-- | is indexed so that we can always tell what the next element should be from a
-- | prior element.
-- |
-- | Running time: `O(1)`
repeat :: forall a. NE.NonEmpty Array a -> InfiniteList (Tuple Int a) a
repeat oxs = IL snd iter firstVal
  where
    ref = index 0 (NE.oneOf $ oxs)

    index :: Int -> Array a -> Array (Tuple Int a)
    index n values = case A.uncons values of
      Just {head: x, tail: xs} -> Tuple n x `A.cons` index (n + 1) xs
      Nothing -> []

    iter :: Tuple Int a -> Tuple Int a
    iter (Tuple cIndex _) = case A.index ref (cIndex + 1) of
      Just x -> x
      Nothing -> firstVal

    firstVal = Tuple 0 (NE.head oxs)

-- | Get the first element of an infinite list. For example:
-- |
-- |     (head $ iterate ((+) 1) 1) `shouldEqual` 1
-- |
-- | The first value in this example infinite list will be a one.
-- |
-- | The maximum performance cost of this method will be however much it takes to
-- | convert a value of type `b` to type `a`.
head :: forall a b. InfiniteList b a -> a
head (IL conv _ x) = conv x

-- | Return the infinite list without the first element. For example:
-- |
-- |     (head <<< tail $ iterate ((+) 1) 1) `shouldEqual` 2
-- |
-- | In this example, we generate the list of natural numbers, drop the first element
-- | and get then following element. This will return the second element of the natural numbers
-- | and, naturally, it is two.
-- |
-- | The maximum performance cost of this method will be however much it takes to
-- | iterate from the previous value of `b` to the next value of `b`.
tail :: forall a b. InfiniteList b a -> InfiniteList b a
tail il = (uncons il).tail

-- | Returns an object that contains two values: `head` and `tail`. These two
-- | values will contain the same data as if you had called the respective head
-- | and tail functions on the original list. This method should only be used as
-- | a convenience method to simplify the head and tail calls.
-- |
-- | Semantically speaking, this method separates the first element of an infinite
-- | list from the remaining elements of the infinite list.
-- |
-- | For example:
-- |
-- |     let s = uncons $ iterate ((+) 1) 1
-- |     s.head `shouldEqual` 1
-- |     head s.tail `shouldEqual` 2
-- |
-- | The performance cost of this method should be the summation of the respective
-- | head and tail calls that you would need to make to get the same result.
uncons :: forall a b. InfiniteList b a -> { head :: a, tail :: InfiniteList b a }
uncons (IL conv iter start) = { head: conv start, tail: IL conv iter (iter start) }

-- | Take the first 'n' elements from an infinite list.
-- |
-- | For example:
-- |
-- |     take 10 (iterate ((+) 1) 1) `shouldEqual` [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
-- |
-- | The performance cost of this function will be approximately O(n) * m where m
-- | is the cost of performing n uncons operations.
take :: forall a b. Int -> InfiniteList b a -> Array a
take = _take uncons
-- TODO when Tail Call Optimization modulo cons is implemented then use this instead: https://github.com/purescript/purescript/issues/2154
{-
take on oil = L.toUnfoldable $ go on oil
  where
    go :: forall a b. Int -> InfiniteList b a -> L.List a
    go n il | n <= 0    = L.Nil
            | otherwise = head il `L.Cons` go (n - 1) (tail il)
-}

foreign import _take :: forall a b. (InfiniteList b a -> { head :: a, tail :: InfiniteList b a }) -> Int -> InfiniteList b a -> Array a

-- | Drop the first 'n' elements from an infinite list and return the resultant infinite list.
-- |
-- | For example:
-- |
-- |     head <<< drop 10 $ (iterate ((+) 1) 1) `shouldEqual` 11
-- |
-- | The performance cost of this function will be approximately O(n) * m where m is the
-- | cost of performing one tail operation.
drop :: forall a b. Int -> InfiniteList b a -> InfiniteList b a
drop n il | n <= 0    = il
          | otherwise = drop (n - 1) (tail il)

-- | Return all of the elements at the start of the infinite list that match the
-- | provided condition.
-- |
-- | For example, to get all of the numbers that, when squared, are less than a thousand:
-- |
-- |     takeWhile (\x -> (x `pow` 2) < 128) $ iterate ((+) 1) 1 `shouldEqual` [1,2,3,4,5,6,7,8,9,10,11]
takeWhile :: forall a b. (a -> Boolean) -> InfiniteList b a -> Array a
takeWhile = _takeWhile uncons
-- TODO when Tail Call Optimization modulo cons is implemented then use this instead: https://github.com/purescript/purescript/issues/2154
{-
takeWhile :: forall a b. (a -> Boolean) -> InfiniteList b a -> Array a
takeWhile keep = L.toUnfoldable <<< go
  where
    go :: InfiniteList b a -> L.List a
    go il = let u = uncons il
            in if keep u.head then u.head `L.Cons` go u.tail else L.Nil
-}

foreign import _takeWhile :: forall a b. (InfiniteList b a -> { head :: a, tail :: InfiniteList b a }) -> (a -> Boolean) -> InfiniteList b a -> Array a

-- | Drop all of the elements from the start of an infinite list that match the
-- | provided condition.
-- |
-- | For example, to drop all of the elements from an infinite list who have log
-- | values of less than 10:
-- |
-- |     (head <<< dropWhile (\x -> log x < 10.0) $ iterate ((+) 1.0) 1.0) `shouldEqual` 22027.0
dropWhile :: forall a b. (a -> Boolean) -> InfiniteList b a -> InfiniteList b a
dropWhile discard = go
  where
    go :: InfiniteList b a -> InfiniteList b a
    go il = if discard (head il) then go (tail il) else il

-- | Zip two infinite lists together.
-- |
-- | The resultant infinite list returns tuples of the original list values. For example:
-- |
-- |     let increasing = iterate ((+) 1)
-- |     let pairs = zip (increasing 0) (increasing 1)
-- |     take 5 pairs `shouldEqual` [(Tuple 0 1),(Tuple 1 2),(Tuple 2 3),(Tuple 3 4),(Tuple 4 5)]
-- |
-- | Running time: O(1)
zip :: forall a b c d. InfiniteList c a -> InfiniteList d b -> InfiniteList (Tuple c d) (Tuple a b)
zip (IL lConv lIter lStart) (IL rConv rIter rStart) = IL conv iter start
  where
    conv (Tuple x y) = Tuple (lConv x) (rConv y)
    iter (Tuple x y) = Tuple (lIter x) (rIter y)
    start = Tuple lStart rStart

-- | Zip two infinite lists together with a data joining function.
-- |
-- | For example:
-- |
-- |     let increasing = iterate ((+) 1)
-- |     let items = zipWith (\n x -> n <> show x) (iterate id "Name: ") (increasing 1)
-- |     take 5 items `shouldEqual` ["Name: 1","Name: 2","Name: 3","Name: 4","Name: 5"]
zipWith :: forall a b c d e. (a -> b -> e) -> InfiniteList c a -> InfiniteList d b -> InfiniteList (Tuple c d) e
zipWith f a = map (uncurry f) <<< zip a

-- | This module allows the creation of infinite lists in Purescript where you
-- | only pay the performance cost for each element in the infinite list when
-- | it is extracted.
-- |
-- | Every infinite list requires three different classes of functions:
-- |
-- | * Generators of infinite lists (iterate, repeat)
-- | * Manipulators of infinite lists (map, filter, zip, tail)
-- | * Getters of data from infinite lists (head, take, takeWhile)

module Data.InfiniteList
  ( InfiniteList
  , iterate
  , repeat
  , take
  , drop
  , takeWhile
  , dropWhile
  , head
  , tail
  , uncons
  , zip
  , zipWith
  , module Exports
  ) where

import Data.Array as A
import Data.Either as E
import Data.Filterable as F
import Data.Filterable (filter) as Exports
import Data.List as L
import Data.NonEmpty as NE
import Data.Function (id)
import Data.Functor (class Functor, map)
import Data.Maybe (Maybe(..), isJust, fromJust)
import Data.Tuple (Tuple(..), snd, uncurry)
import Partial.Unsafe (unsafePartialBecause)
import Prelude ((-), (+), ($), (<<<), (<=), otherwise)

-- | The datatype that represents an infinite list. The two type arguments are:
-- |
-- | * `a`: The type that will be returned by the getter methods.
-- | * `b`: The base type for this infinite list that is being iterated over.
data InfiniteList b a = IL (b -> a) (b -> b) b

-- Can't implement these classes
-- Eq: can't compare functions
-- Show: can't iterate the whole list...will let other people implement custom show methods
-- Ord: Requires Eq to be possible
-- Semigroup: Would be stupid ... since the lists are infinite xs <> ys => xs because you would never get to the elements of ys
-- Monoid: Infinite lists, by definition, cannot be empty. What would mempty be?
-- Foldable: You can't fold an infinite list
-- Traversable: You can't traverse the entirity of an infinite list
-- Alt: No, for the same reason as semigroup
-- Plus: Depends on Alt

instance infiniteFunctor :: Functor (InfiniteList a) where
  map f (IL conv iter start) = IL (f <<< conv) iter start

instance infiniteFilterable :: F.Filterable (InfiniteList a) where
  partitionMap = partitionMapInternal

  partition = partitionInternal

  filterMap = filterMapInternal

  filter = filterInternal

partitionMapInternal :: forall a b l r. (a -> E.Either l r) -> InfiniteList b a -> { left :: InfiniteList b l, right :: InfiniteList b r }
partitionMapInternal f il = {
    left: fromLeft applied,
    right: fromRight applied
  }
  where
    applied = map f il

fromLeft :: forall a b c. InfiniteList b (E.Either a c) -> InfiniteList b a
fromLeft = map (unsafePartialBecause "We have filtered on only the left elements" E.fromLeft) <<< filterInternal E.isLeft

fromRight :: forall a b c. InfiniteList b (E.Either c a) -> InfiniteList b a
fromRight = map (unsafePartialBecause "We have filtered on only the right elements" E.fromRight) <<< filterInternal E.isRight

partitionInternal :: forall a b. (a -> Boolean) -> InfiniteList b a -> { no :: InfiniteList b a, yes :: InfiniteList b a }
partitionInternal p xs = let o = partitionMapInternal (F.eitherBool p) xs
                         in {no: o.left, yes: o.right}

filterMapInternal :: forall a b c. (a -> Maybe c) -> InfiniteList b a -> InfiniteList b c
filterMapInternal f = catMaybes <<< map f

catMaybes :: forall b a. InfiniteList b (Maybe a) -> InfiniteList b a
catMaybes = map (unsafePartialBecause "We have filtered on only the Just elements" fromJust) <<< filterInternal isJust

filterInternal :: forall a b. (a -> Boolean) -> InfiniteList b a -> InfiniteList b a
filterInternal matches (IL conv iter start) = IL conv next nextStart
  where
    nextStart = if matches' start then start else next start

    next x = let step = iter x in
             if matches' step then step else next step

    matches' = matches <<< conv

-- We could possibly implement Apply if the need for it was there

-- | Generate an infinite list by providing:
-- |
-- |  * a function to iterate from the previous value in the infinite list to the next AND
-- |  * the first element in the infinite list to begin the iteration.
-- |
-- | For example, to generate the list of natural numbers you can do the following:
-- |
-- |     naturals = iterate ((+) 1) 1
-- |
-- | In english, "The natural numbers start at 1 and you can get the next natural
-- | number by adding one to the prior number".
-- |
-- | Running time: `O(1)`
iterate :: forall a. (a -> a) -> a -> InfiniteList a a
iterate iter start = IL id iter start

-- | Generate an infinite list by infinitely repeating a provided non-empty list.
-- |
-- | The list that is provided must be non-empty because it is impossible to repeat
-- | an empty list and end up with a list with something in it.
-- |
-- | To see how this method works see the following example:
-- |
-- |     > IL.take 15 $ repeat (0 :| fromFoldable [2, 1, 3])
-- |     (0 : 2 : 1 : 3 : 0 : 2 : 1 : 3 : 0 : 2 : 1 : 3 : 0 : 2 : 1 : Nil)
-- |
-- |     >
-- |
-- | This is an infinite repeat of the list 0, 2, 1, 3.
-- |
-- | Note: You will notice that an `InfiniteList (Tuple Int a) a` is returned, the
-- | reason for the tuple in the type is that the non-empty list that is passed in
-- | is indexed so that we can always tell what the next element should be from a
-- | prior element.
-- |
-- | Running time: `O(1)`
repeat :: forall a. NE.NonEmpty Array a -> InfiniteList (Tuple Int a) a
repeat oxs = IL snd iter firstVal
  where
    ref = index 0 (NE.oneOf $ oxs)

    index :: Int -> Array a -> Array (Tuple Int a)
    index n values = case A.uncons values of
      Just {head: x, tail: xs} -> Tuple n x `A.cons` index (n + 1) xs
      Nothing -> []

    iter :: Tuple Int a -> Tuple Int a
    iter (Tuple cIndex _) = case A.index ref (cIndex + 1) of
      Just x -> x
      Nothing -> firstVal

    firstVal = Tuple 0 (NE.head oxs)

-- | Get the first element of an infinite list. For example:
-- |
-- |     (head $ iterate ((+) 1) 1) `shouldEqual` 1
-- |
-- | The first value in this example infinite list will be a one.
-- |
-- | The maximum performance cost of this method will be however much it takes to
-- | convert a value of type `b` to type `a`.
head :: forall a b. InfiniteList b a -> a
head (IL conv _ x) = conv x

-- | Return the infinite list without the first element. For example:
-- |
-- |     (head <<< tail $ iterate ((+) 1) 1) `shouldEqual` 2
-- |
-- | In this example, we generate the list of natural numbers, drop the first element
-- | and get then following element. This will return the second element of the natural numbers
-- | and, naturally, it is two.
-- |
-- | The maximum performance cost of this method will be however much it takes to
-- | iterate from the previous value of `b` to the next value of `b`.
tail :: forall a b. InfiniteList b a -> InfiniteList b a
tail il = (uncons il).tail

-- | Returns an object that contains two values: `head` and `tail`. These two
-- | values will contain the same data as if you had called the respective head
-- | and tail functions on the original list. This method should only be used as
-- | a convenience method to simplify the head and tail calls.
-- |
-- | Semantically speaking, this method separates the first element of an infinite
-- | list from the remaining elements of the infinite list.
-- |
-- | For example:
-- |
-- |     let s = uncons $ iterate ((+) 1) 1
-- |     s.head `shouldEqual` 1
-- |     head s.tail `shouldEqual` 2
-- |
-- | The performance cost of this method should be the summation of the respective
-- | head and tail calls that you would need to make to get the same result.
uncons :: forall a b. InfiniteList b a -> { head :: a, tail :: InfiniteList b a }
uncons (IL conv iter start) = { head: conv start, tail: IL conv iter (iter start) }

-- | Take the first 'n' elements from an infinite list.
-- |
-- | For example:
-- |
-- |     take 10 (iterate ((+) 1) 1) `shouldEqual` [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
-- |
-- | The performance cost of this function will be approximately O(n) * m where m
-- | is the cost of performing n uncons operations.
take :: forall a b. Int -> InfiniteList b a -> Array a
take = _take uncons
-- TODO when Tail Call Optimization modulo cons is implemented then use this instead: https://github.com/purescript/purescript/issues/2154
{-
take on oil = L.toUnfoldable $ go on oil
  where
    go :: forall a b. Int -> InfiniteList b a -> L.List a
    go n il | n <= 0    = L.Nil
            | otherwise = head il `L.Cons` go (n - 1) (tail il)
-}

foreign import _take :: forall a b. (InfiniteList b a -> { head :: a, tail :: InfiniteList b a }) -> Int -> InfiniteList b a -> Array a

-- | Drop the first 'n' elements from an infinite list and return the resultant infinite list.
-- |
-- | For example:
-- |
-- |     head <<< drop 10 $ (iterate ((+) 1) 1) `shouldEqual` 11
-- |
-- | The performance cost of this function will be approximately O(n) * m where m is the
-- | cost of performing one tail operation.
drop :: forall a b. Int -> InfiniteList b a -> InfiniteList b a
drop n il | n <= 0    = il
          | otherwise = drop (n - 1) (tail il)

-- | Return all of the elements at the start of the infinite list that match the
-- | provided condition.
-- |
-- | For example, to get all of the numbers that, when squared, are less than a thousand:
-- |
-- |     takeWhile (\x -> (x `pow` 2) < 128) $ iterate ((+) 1) 1 `shouldEqual` [1,2,3,4,5,6,7,8,9,10,11]
takeWhile :: forall a b. (a -> Boolean) -> InfiniteList b a -> Array a
takeWhile = _takeWhile uncons
-- TODO when Tail Call Optimization modulo cons is implemented then use this instead: https://github.com/purescript/purescript/issues/2154
{-
takeWhile :: forall a b. (a -> Boolean) -> InfiniteList b a -> Array a
takeWhile keep = L.toUnfoldable <<< go
  where
    go :: InfiniteList b a -> L.List a
    go il = let u = uncons il
            in if keep u.head then u.head `L.Cons` go u.tail else L.Nil
-}

foreign import _takeWhile :: forall a b. (InfiniteList b a -> { head :: a, tail :: InfiniteList b a }) -> (a -> Boolean) -> InfiniteList b a -> Array a

-- | Drop all of the elements from the start of an infinite list that match the
-- | provided condition.
-- |
-- | For example, to drop all of the elements from an infinite list who have log
-- | values of less than 10:
-- |
-- |     (head <<< dropWhile (\x -> log x < 10.0) $ iterate ((+) 1.0) 1.0) `shouldEqual` 22027.0
dropWhile :: forall a b. (a -> Boolean) -> InfiniteList b a -> InfiniteList b a
dropWhile discard = go
  where
    go :: InfiniteList b a -> InfiniteList b a
    go il = if discard (head il) then go (tail il) else il

-- | Zip two infinite lists together.
-- |
-- | The resultant infinite list returns tuples of the original list values. For example:
-- |
-- |     let increasing = iterate ((+) 1)
-- |     let pairs = zip (increasing 0) (increasing 1)
-- |     take 5 pairs `shouldEqual` [(Tuple 0 1),(Tuple 1 2),(Tuple 2 3),(Tuple 3 4),(Tuple 4 5)]
-- |
-- | Running time: O(1)
zip :: forall a b c d. InfiniteList c a -> InfiniteList d b -> InfiniteList (Tuple c d) (Tuple a b)
zip (IL lConv lIter lStart) (IL rConv rIter rStart) = IL conv iter start
  where
    conv (Tuple x y) = Tuple (lConv x) (rConv y)
    iter (Tuple x y) = Tuple (lIter x) (rIter y)
    start = Tuple lStart rStart

-- | Zip two infinite lists together with a data joining function.
-- |
-- | For example:
-- |
-- |     let increasing = iterate ((+) 1)
-- |     let items = zipWith (\n x -> n <> show x) (iterate id "Name: ") (increasing 1)
-- |     take 5 items `shouldEqual` ["Name: 1","Name: 2","Name: 3","Name: 4","Name: 5"]
zipWith :: forall a b c d e. (a -> b -> e) -> InfiniteList c a -> InfiniteList d b -> InfiniteList (Tuple c d) e
zipWith f a = map (uncurry f) <<< zip a