requests now take a port as their first argument

module PscIde where

import PscIde.Command
import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Argonaut (class DecodeJson, class EncodeJson, encodeJson)
import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Prelude (Unit, pure, (<$>), (>>>), show)

foreign import data NET :: !

foreign import send
  :: forall eff.
  String  -- ^ Command
  -> Int -- ^ Port
  -> (String -> Eff (net :: NET | eff) Unit)  -- ^ Callback
  -> (Error -> Eff (net :: NET | eff) Unit)  -- ^ Error Callback
  -> Eff (net :: NET | eff) Unit

type Cmd a = forall eff. Aff (net :: NET | eff) (Result a)
type CmdR a b = forall eff. Aff (net :: NET | eff) (Result (Either a b))

sendCommandR :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) => Int -> i -> CmdR oe o
sendCommandR port command =
  makeAff \err succ ->
            send (show (encodeJson command)) port (unwrapResponse >>> succ) err

sendCommand :: forall i o. (EncodeJson i, DecodeJson o) => Int -> i -> Cmd o
sendCommand port command =
  makeAff \err succ ->
            send (show (encodeJson command)) port (unwrapResponse >>> join >>> succ) err

cwd :: Int -> Cmd Message
cwd port = sendCommand port Cwd

listLoadedModules :: Int -> Cmd ModuleList
listLoadedModules port = sendCommand port (Ls LoadedModules)

listAvailableModules :: Int -> Cmd ModuleList
listAvailableModules port = sendCommand port (Ls AvailableModules)

listImports :: Int -> String -> Cmd ImportList
listImports port fp = sendCommand port (Ls (Imports fp))

load :: Int -> Array String -> Array String -> Cmd Message
load port ms ds = sendCommand port (Load ms ds)

quit :: Int -> Cmd Message
quit port = sendCommand port Quit

pursuitCompletion :: Int -> String -> Cmd (Array PursuitCompletion)
pursuitCompletion port q = sendCommand port (Pursuit Ident q)

complete :: Int -> Array Filter -> Maybe Matcher -> Cmd (Array Completion)
complete port fs m = sendCommand port (Complete fs m)

type':: Int -> String -> Array Filter -> Cmd (Array Completion)
type' port s fs = sendCommand port (Type s fs)

suggestTypos :: Int -> String -> Int -> Cmd (Array Completion)
suggestTypos port q m = (_ <|> pure []) <$> complete port [] (Just (Distance q m))

addClause :: Int -> String -> Boolean -> Cmd (Array String)
addClause port line annotations = sendCommand port (AddClause line annotations)

caseSplit :: Int -> String -> Int -> Int -> Boolean -> String -> Cmd (Array String)
caseSplit port line begin end annotations typ =
  sendCommand port (CaseSplit line begin end annotations typ)

implicitImport :: Int -> String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
implicitImport port infile outfile filters mod = sendCommand port (ImportCmd infile outfile filters (AddImplicitImport mod))

explicitImport :: Int -> String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
explicitImport port infile outfile filters ident = sendCommand port (ImportCmd infile outfile filters (AddImport ident))

rebuild :: Int -> String -> CmdR RebuildResult RebuildResult
rebuild port file = sendCommandR port (RebuildCmd file)

module PscIde where

import PscIde.Command
import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Argonaut (class DecodeJson, class EncodeJson, encodeJson)
import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Prelude (Unit, pure, (<$>), (>>>), show)

foreign import data NET :: !

foreign import send :: forall eff.
  String -> -- ^ Command
  Int ->  -- ^ Port
  (String -> Eff (net :: NET | eff) Unit) -> -- ^ Callback
  (Error -> Eff (net :: NET | eff) Unit) -> -- ^ Error Callback
  Eff (net :: NET | eff) Unit

type Cmd a = forall eff. Aff (net :: NET | eff) (Result a)
type CmdR a b = forall eff. Aff (net :: NET | eff) (Result (Either a b))

sendCommandG :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) =>
                Int -> i -> (String -> Result (Either oe o)) -> CmdR oe o
sendCommandG port command unwrapper =
  makeAff (\err succ ->
            send (show (encodeJson command)) port (unwrapper >>> succ) err)

sendCommandR :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) => Int -> i -> CmdR oe o
sendCommandR port command = sendCommandG port command unwrapResponse

sendCommand :: forall i o. (EncodeJson i, DecodeJson o) => Int -> i -> Cmd o
sendCommand port command =
  makeAff (\err succ ->
            send (show (encodeJson command)) port (unwrapResponse >>> join >>> succ) err)

cwd :: Int -> Cmd Message
cwd port = sendCommand port Cwd

listLoadedModules :: Int -> Cmd ModuleList
listLoadedModules port = sendCommand port (Ls LoadedModules)

listAvailableModules :: Int -> Cmd ModuleList
listAvailableModules port = sendCommand port (Ls AvailableModules)

listImports :: Int -> String -> Cmd ImportList
listImports port fp = sendCommand port (Ls (Imports fp))

load ::
  Int ->
  Array String ->
  Array String ->
  Cmd Message
load port ms ds = sendCommand port (Load ms ds)

quit :: Int -> Cmd Message
quit port = sendCommand port Quit

pursuitCompletion :: Int -> String -> Cmd (Array PursuitCompletion)
pursuitCompletion port q = sendCommand port (Pursuit Ident q)

complete ::
  Int ->
  Array Filter ->
  Maybe Matcher ->
  Cmd (Array Completion)
complete port fs m = sendCommand port (Complete fs m)

type' ::
  Int ->
  String ->
  Array Filter ->
  Cmd (Array Completion)
type' port s fs = sendCommand port (Type s fs)

suggestTypos ::
  Int ->
  String ->
  Int ->
  Cmd (Array Completion)
suggestTypos port q m = (_ <|> pure []) <$> complete port [] (Just (Distance q m))

addClause :: Int -> String -> Boolean -> Cmd (Array String)
addClause port line annotations = sendCommand port (AddClause line annotations)

caseSplit :: Int -> String -> Int -> Int -> Boolean -> String -> Cmd (Array String)
caseSplit port line begin end annotations typ =
  sendCommand port (CaseSplit line begin end annotations typ)

implicitImport :: Int -> String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
implicitImport port infile outfile filters mod = sendCommand port (ImportCmd infile outfile filters (AddImplicitImport mod))

explicitImport :: Int -> String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
explicitImport port infile outfile filters ident = sendCommand port (ImportCmd infile outfile filters (AddImport ident))

rebuild :: Int -> String -> CmdR RebuildResult RebuildResult
rebuild port file = sendCommandR port (RebuildCmd file)


Max size on draftboard gen

Max size on draftboard gen

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Model
  ( Model
  , eqModel
  , genModel
  , emptyModel
  , encode
  , decode
  ) where

import SlamData.Prelude
import Data.Argonaut as J
import Data.Argonaut ((~>), (:=), (.?))
import Data.Function (on)
import Data.Int (floor)
import Data.List(List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe as Maybe
import Data.Ratio as Ratio
import Data.Rational (Rational(..), (%))
import Data.Rational as Rational
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Deck.DeckId (DeckId)
import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen
import Math as Math

type Model =
  { layout ∷ Pane.Pane (Maybe DeckId)
  }

eqModel
  ∷ Model
  → Model
  → Boolean
eqModel m1 m2 =
  m1.layout ≡ m2.layout

genModel ∷ Gen.Gen Model
genModel =
  { layout: _ } <$> genPane 5

emptyModel ∷ Model
emptyModel = { layout: Pane.Cell Nothing }

encode
  ∷ Model
  → J.Json
encode m =
  "layout" := encodePane m.layout
    ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj → decodeLayout obj <|> decodeDecks obj

  where
  decodeLayout obj = do
    layout ← decodePane =<< obj .? "layout"
    pure { layout }

  decodeDecks obj = do
    decks ∷ Map.Map DeckId DeckPosition ←
      traverse decodeDeckPosition =<< obj .? "decks"
    let
      layout = migrateLayout decks
    pure { layout }

encodePane
  ∷ ∀ a
  . J.EncodeJson a
  ⇒ Pane.Pane a
  → J.Json
encodePane = case _ of
  Pane.Cell a →
    "type" := "cell"
    ~> "value" := J.encodeJson a
    ~> J.jsonEmptyObject
  Pane.Split orn ps →
    "type" := "split"
      ~> "orientation" := encodeOrientation orn
      ~> "panes" := map encodeSplit ps
      ~> J.jsonEmptyObject
  where
  encodeSplit (Rational r × p) =
    "ratio" := J.encodeJson (Ratio.numerator r × Ratio.denominator r)
      ~> "pane" :=  encodePane p
      ~> J.jsonEmptyObject

decodePane
  ∷ ∀ a
  . J.DecodeJson a
  ⇒ J.Json
  → Either String (Pane.Pane a)
decodePane =
  J.decodeJson >=> \obj → do
    ty ← obj .? "type"
    case ty of
      "cell" → do
        value ← obj .? "value"
        pure (Pane.Cell value)
      "split" → do
        orn ← decodeOrientation =<< obj .? "orientation"
        ps ← traverse decodeSplits =<< obj .? "panes"
        pure (Pane.Split orn ps)
      _ → do
        Left ("Not a valid Pane tag: " <> ty)
  where
  decodeSplits obj = do
    n × d ← obj .? "ratio"
    pane ← decodePane =<< obj .? "pane"
    pure (n%d × pane)

genPane
  ∷ ∀ a
  . SC.Arbitrary a
  ⇒ Int
  → Gen.Gen (Pane.Pane a)
genPane size = genOrientation >>= goGen size
  where
  goGen n orn = do
    bool ← SC.arbitrary
    if n ≡ 0 || bool
      then Pane.Cell <$> SC.arbitrary
      else Pane.Split orn <$> genSplit n orn 16 List.Nil

  genSplit n orn range ps = do
    num ← Gen.chooseInt 1 range
    pane ← goGen (n - 1) (Orn.reverse orn)
    let
      ps' = List.Cons ((num%16) × pane) ps
      range' = range - num
    if range' ≡ 0
      then pure ps'
      else genSplit n orn range' ps'

encodeOrientation ∷ Orn.Orientation → J.Json
encodeOrientation = J.encodeJson ∘ Orn.toString

decodeOrientation ∷ J.Json → Either String Orn.Orientation
decodeOrientation = J.decodeJson >=> case _ of
  "vertical" → pure Orn.Vertical
  "horizontal" → pure Orn.Horizontal
  s → Left ("Invalid orientation: " <> s)

genOrientation ∷ Gen.Gen Orn.Orientation
genOrientation = SC.arbitrary <#> if _ then Orn.Vertical else Orn.Horizontal

type DeckPosition =
  { x ∷ Number
  , y ∷ Number
  , width ∷ Number
  , height ∷ Number
  }

decodeDeckPosition
  ∷ J.Json
  → Either String DeckPosition
decodeDeckPosition =
  J.decodeJson >=> \obj → do
    x ← obj .? "x"
    y ← obj .? "y"
    width ← obj .? "width"
    height ← obj .? "height"
    pure { x, y, width, height }

migrateLayout
  ∷ Map.Map DeckId DeckPosition
  → Pane.Pane (Maybe DeckId)
migrateLayout decks =
  splitTop total Nil deckList

  where
  deckList =
    List.sortBy (compare `on` (snd ⋙ \r → Math.sqrt ((r.x * r.x) + (r.y * r.y))))
      $ Map.toList decks

  total =
    let
      size =
        foldl
          (\acc r →
            { width: if r.x + r.width > acc.width then r.x + r.width else acc.width
            , height: if r.y + r.height > acc.height then r.y + r.height else acc.height
            })
          { width: 0.0, height: 0.0 }
          decks
    in case deckList of
      List.Cons (_ × rect) _ →
        { x: rect.x
        , y: rect.y
        , width: size.width - rect.x
        , height: size.height - rect.y
        }
      _ →
        { x: 0.0
        , y: 0.0
        , width: 0.0
        , height: 0.0
        }

  splitTop r1 Nil Nil =
    Pane.Cell Nothing
  splitTop r1 ps Nil =
    splitLeft r1 Nil ps
  splitTop r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitTop r1 ps ((deckId × r2) : ds) | r2.y - r1.y == 0.0 =
    splitTop r1 ((deckId × r2) : ps) ds
  splitTop r1 ps ((deckId × r2) : ds) =
    case trySplitV r2.y (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.y - r1.y) % floor r1.height
          r1'   = r1 { height = r2.y - r1.y }
        in case bs of
          Nil →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (Pane.wrap Orn.Horizontal (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (splitLeft r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitTop r1 ((deckId × r2) : ps) ds

  splitLeft r1 Nil Nil =
    Pane.Cell Nothing
  splitLeft r1 ps Nil =
    splitTop r1 Nil ps
  splitLeft r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitLeft r1 ps ((deckId × r2) : ds) | r2.x - r1.x == 0.0 =
    splitLeft r1 ((deckId × r2) : ps) ds
  splitLeft r1 ps ((deckId × r2) : ds) =
    case trySplitH r2.x (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.x - r1.x) % floor r1.width
          r1'   = r1 { width = r2.x - r1.x }
        in case bs of
          Nil →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (Pane.wrap Orn.Vertical (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (splitTop r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitLeft r1 ((deckId × r2) : ps) ds

  trySplitH = trySplit Orn.Horizontal Nil Nil
  trySplitV = trySplit Orn.Vertical Nil Nil

  trySplit orn a b z Nil = Just (a × b)
  trySplit orn a b z ((deckId × r) : ds) =
    case orn of
      Orn.Horizontal →
        if z > r.x && z < r.x + r.width then
          Nothing
        else if r.x < z then
          trySplit orn ((deckId × r) : a) b z ds
        else
          trySplit orn a ((deckId × r) : b) z ds
      Orn.Vertical →
        if z > r.y && z < r.y + r.height then
          Nothing
        else if r.y < z then
          trySplit orn ((deckId × r) : a) b z ds
        else
          trySplit orn a ((deckId × r) : b) z ds

  merge orn ratio a b =
    let
      ps = List.fromFoldable [ ratio × Pane.Cell Nothing, (one - ratio) × Pane.Cell Nothing ]
    in case (Layout.defaultMerge orn ps 0 a), (Layout.defaultMerge orn ps 1 b) of
      Pane.Split _ as, Pane.Split _ bs →
        let
          as' = unsafePartial (Maybe.fromJust (List.init as))
          bs' = unsafePartial (Maybe.fromJust (List.tail bs))
        in
          Pane.Split orn (bestFit zero Nil (as' <> bs'))
      _, _ →
        -- Should never happen
        Pane.Split orn ps

  bestFit off acc Nil = Nil
  bestFit off acc ((_ × p) : Nil) =
    List.reverse ((one - off × p) : acc)
  bestFit off acc ((ratio × p) : ps) =
    let
      ratio' = Layout.closestSnapRatio (Rational.toNumber ratio)
    in
      bestFit (off + ratio') ((ratio' × p) : acc) ps

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Draftboard.Model
  ( Model
  , eqModel
  , genModel
  , emptyModel
  , encode
  , decode
  ) where

import SlamData.Prelude
import Data.Argonaut as J
import Data.Argonaut ((~>), (:=), (.?))
import Data.Function (on)
import Data.Int (floor)
import Data.List(List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe as Maybe
import Data.Ratio as Ratio
import Data.Rational (Rational(..), (%))
import Data.Rational as Rational
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Deck.DeckId (DeckId)
import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen
import Math as Math

type Model =
  { layout ∷ Pane.Pane (Maybe DeckId)
  }

eqModel
  ∷ Model
  → Model
  → Boolean
eqModel m1 m2 =
  m1.layout ≡ m2.layout

genModel ∷ Gen.Gen Model
genModel =
  { layout: _ } <$> genPane

emptyModel ∷ Model
emptyModel = { layout: Pane.Cell Nothing }

encode
  ∷ Model
  → J.Json
encode m =
  "layout" := encodePane m.layout
    ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj → decodeLayout obj <|> decodeDecks obj

  where
  decodeLayout obj = do
    layout ← decodePane =<< obj .? "layout"
    pure { layout }

  decodeDecks obj = do
    decks ∷ Map.Map DeckId DeckPosition ←
      traverse decodeDeckPosition =<< obj .? "decks"
    let
      layout = migrateLayout decks
    pure { layout }

encodePane
  ∷ ∀ a
  . J.EncodeJson a
  ⇒ Pane.Pane a
  → J.Json
encodePane = case _ of
  Pane.Cell a →
    "type" := "cell"
    ~> "value" := J.encodeJson a
    ~> J.jsonEmptyObject
  Pane.Split orn ps →
    "type" := "split"
      ~> "orientation" := encodeOrientation orn
      ~> "panes" := map encodeSplit ps
      ~> J.jsonEmptyObject
  where
  encodeSplit (Rational r × p) =
    "ratio" := J.encodeJson (Ratio.numerator r × Ratio.denominator r)
      ~> "pane" :=  encodePane p
      ~> J.jsonEmptyObject

decodePane
  ∷ ∀ a
  . J.DecodeJson a
  ⇒ J.Json
  → Either String (Pane.Pane a)
decodePane =
  J.decodeJson >=> \obj → do
    ty ← obj .? "type"
    case ty of
      "cell" → do
        value ← obj .? "value"
        pure (Pane.Cell value)
      "split" → do
        orn ← decodeOrientation =<< obj .? "orientation"
        ps ← traverse decodeSplits =<< obj .? "panes"
        pure (Pane.Split orn ps)
      _ → do
        Left ("Not a valid Pane tag: " <> ty)
  where
  decodeSplits obj = do
    n × d ← obj .? "ratio"
    pane ← decodePane =<< obj .? "pane"
    pure (n%d × pane)

genPane
  ∷ ∀ a
  . SC.Arbitrary a
  ⇒ Gen.Gen (Pane.Pane a)
genPane = genOrientation >>= goGen
  where
  goGen orn =
    SC.arbitrary >>=
    if _
      then Pane.Cell <$> SC.arbitrary
      else Pane.Split orn <$> genSplit orn 16 List.Nil

  genSplit orn range ps = do
    num ← Gen.chooseInt 1 range
    pane ← goGen (Orn.reverse orn)
    let
      ps' = List.Cons ((num%16) × pane) ps
      range' = range - num
    if range' ≡ 0
      then pure ps'
      else genSplit orn range' ps'

encodeOrientation ∷ Orn.Orientation → J.Json
encodeOrientation = J.encodeJson ∘ Orn.toString

decodeOrientation ∷ J.Json → Either String Orn.Orientation
decodeOrientation = J.decodeJson >=> case _ of
  "vertical" → pure Orn.Vertical
  "horizontal" → pure Orn.Horizontal
  s → Left ("Invalid orientation: " <> s)

genOrientation ∷ Gen.Gen Orn.Orientation
genOrientation = SC.arbitrary <#> if _ then Orn.Vertical else Orn.Horizontal

type DeckPosition =
  { x ∷ Number
  , y ∷ Number
  , width ∷ Number
  , height ∷ Number
  }

decodeDeckPosition
  ∷ J.Json
  → Either String DeckPosition
decodeDeckPosition =
  J.decodeJson >=> \obj → do
    x ← obj .? "x"
    y ← obj .? "y"
    width ← obj .? "width"
    height ← obj .? "height"
    pure { x, y, width, height }

migrateLayout
  ∷ Map.Map DeckId DeckPosition
  → Pane.Pane (Maybe DeckId)
migrateLayout decks =
  splitTop total Nil deckList

  where
  deckList =
    List.sortBy (compare `on` (snd ⋙ \r → Math.sqrt ((r.x * r.x) + (r.y * r.y))))
      $ Map.toList decks

  total =
    let
      size =
        foldl
          (\acc r →
            { width: if r.x + r.width > acc.width then r.x + r.width else acc.width
            , height: if r.y + r.height > acc.height then r.y + r.height else acc.height
            })
          { width: 0.0, height: 0.0 }
          decks
    in case deckList of
      List.Cons (_ × rect) _ →
        { x: rect.x
        , y: rect.y
        , width: size.width - rect.x
        , height: size.height - rect.y
        }
      _ →
        { x: 0.0
        , y: 0.0
        , width: 0.0
        , height: 0.0
        }

  splitTop r1 Nil Nil =
    Pane.Cell Nothing
  splitTop r1 ps Nil =
    splitLeft r1 Nil ps
  splitTop r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitTop r1 ps ((deckId × r2) : ds) | r2.y - r1.y == 0.0 =
    splitTop r1 ((deckId × r2) : ps) ds
  splitTop r1 ps ((deckId × r2) : ds) =
    case trySplitV r2.y (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.y - r1.y) % floor r1.height
          r1'   = r1 { height = r2.y - r1.y }
        in case bs of
          Nil →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (Pane.wrap Orn.Horizontal (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (splitLeft r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitTop r1 ((deckId × r2) : ps) ds

  splitLeft r1 Nil Nil =
    Pane.Cell Nothing
  splitLeft r1 ps Nil =
    splitTop r1 Nil ps
  splitLeft r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitLeft r1 ps ((deckId × r2) : ds) | r2.x - r1.x == 0.0 =
    splitLeft r1 ((deckId × r2) : ps) ds
  splitLeft r1 ps ((deckId × r2) : ds) =
    case trySplitH r2.x (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.x - r1.x) % floor r1.width
          r1'   = r1 { width = r2.x - r1.x }
        in case bs of
          Nil →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (Pane.wrap Orn.Vertical (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (splitTop r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitLeft r1 ((deckId × r2) : ps) ds

  trySplitH = trySplit Orn.Horizontal Nil Nil
  trySplitV = trySplit Orn.Vertical Nil Nil

  trySplit orn a b z Nil = Just (a × b)
  trySplit orn a b z ((deckId × r) : ds) =
    case orn of
      Orn.Horizontal →
        if z > r.x && z < r.x + r.width then
          Nothing
        else if r.x < z then
          trySplit orn ((deckId × r) : a) b z ds
        else
          trySplit orn a ((deckId × r) : b) z ds
      Orn.Vertical →
        if z > r.y && z < r.y + r.height then
          Nothing
        else if r.y < z then
          trySplit orn ((deckId × r) : a) b z ds
        else
          trySplit orn a ((deckId × r) : b) z ds

  merge orn ratio a b =
    let
      ps = List.fromFoldable [ ratio × Pane.Cell Nothing, (one - ratio) × Pane.Cell Nothing ]
    in case (Layout.defaultMerge orn ps 0 a), (Layout.defaultMerge orn ps 1 b) of
      Pane.Split _ as, Pane.Split _ bs →
        let
          as' = unsafePartial (Maybe.fromJust (List.init as))
          bs' = unsafePartial (Maybe.fromJust (List.tail bs))
        in
          Pane.Split orn (bestFit zero Nil (as' <> bs'))
      _, _ →
        -- Should never happen
        Pane.Split orn ps

  bestFit off acc Nil = Nil
  bestFit off acc ((_ × p) : Nil) =
    List.reverse ((one - off × p) : acc)
  bestFit off acc ((ratio × p) : ps) =
    let
      ratio' = Layout.closestSnapRatio (Rational.toNumber ratio)
    in
      bestFit (off + ratio') ((ratio' × p) : acc) ps


Added load operations

Added load operations

module Ops where

import Prelude
import Data.Int.Bits
import Data.Maybe
import Data.Array ((!!)) as A

import Types
import MainMem

--NOTE: consider moving the timings to 2D arrays.
--separate from the opcode's logic

-- Additions
-- =========

--ADD A,R
addRegToA :: GetReg -> Regs -> Regs
addRegToA getReg regs = addXToA (getReg regs) regs

--ADD A,(HL)
addHLMemToA :: Mem -> Regs
addHLMemToA { mainMem, regs } = (addXToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADD A,n
addImmToA :: Mem -> Regs
addImmToA { mainMem, regs } =
  (addXToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

addXToA :: I8 -> Regs -> Regs
addXToA x regs =
  regs {a = sum.res, f = sum.flags, m = 1}
 where sum = addI8s regs.a x

--ADC A,R
addRegCarryToA :: GetReg -> Regs -> Regs
addRegCarryToA getReg regs = addXCarryToA (getReg regs) regs

--ADC A,(HL)
addHLMemCarryToA :: Mem -> Regs
addHLMemCarryToA { mainMem, regs } = (addXCarryToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADC A,n
addImmCarryToA :: Mem -> Regs
addImmCarryToA { mainMem, regs } =
  (addXCarryToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
addXCarryToA :: I8 -> Regs -> Regs
addXCarryToA x regs =
  regs {a = sum.res, f = f', m = 1}
 where
  --Overriding addI8's half-carry flag because it used regs.a+carry
  --Which is essential for the other flags, but not for this one.
  f' = setHalfCarryFlag x regs.a sum.res sum.flags
  sum = addI8s (regs.a + carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

--ADD SP,|n|
addImmToSP :: Mem -> Regs
addImmToSP { regs, mainMem } =
  regs {sp = sp', pc = regs.pc + 1, m = 4}
 where
  sp' = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 regs.pc mainMem

addI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
addI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testCarryFlag8 sum
       .|. testHalfCarryFlag x1 x2 res
  res = sum .&. 255
  sum = x1 + x2

--ADD HL,RR
add2RegsToHL :: GetReg -> GetReg -> Regs -> Regs
add2RegsToHL msByteReg lsByteReg regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl joinedRegs regs.f
  joinedRegs = joinRegs msByteReg lsByteReg regs
  hl = joinRegs h l regs

--ADD HL,SP
addSPToHL :: Regs -> Regs
addSPToHL regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl regs.sp regs.f
  hl = joinRegs h l regs

addI16s :: I8 -> I16 -> I16 -> { res :: I16, flags :: I8 }
addI16s oldFlags x1 x2 = { res, flags }
 where
  flags =  setCarryFlag16 sum
        $  oldFlags
       .|. testZeroFlag res
  res = sum .&. 0xFFFF
  sum = x1 + x2

-- Subtractions
-- ============

--SUB A,R
subRegFromA :: GetReg -> Regs -> Regs
subRegFromA getReg regs = subXFromA (getReg regs) regs

--SUB A,(HL)
subHLMemFromA :: Mem -> Regs
subHLMemFromA { mainMem, regs } = (subXFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SUB A,n
subImmFromA :: Mem -> Regs
subImmFromA { mainMem, regs } = (subXFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Subtractions and additions are relatively similar. Consider
--Using same functions for both, if it doesn't obfuscate much.
subXFromA :: I8 -> Regs -> Regs
subXFromA x regs =
  regs {a = diff.res, f = diff.flags, m = 1}
 where diff = subI8s regs.a x

--SBC A,R
subRegCarryFromA :: GetReg -> Regs -> Regs
subRegCarryFromA getReg regs = subXCarryFromA (getReg regs) regs

--SBC A,(HL)
subHLMemCarryFromA :: Mem -> Regs
subHLMemCarryFromA { mainMem, regs } = (subXCarryFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SBC A,n
subImmCarryToA :: Mem -> Regs
subImmCarryToA { mainMem, regs } = (subXCarryFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
subXCarryFromA :: I8 -> Regs -> Regs
subXCarryFromA x regs =
  regs {a = diff.res, f = f', m = 1}
 where
  f' = setHalfCarryFlag x regs.a diff.res diff.flags
  diff = subI8s (regs.a - carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

subI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
subI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testNegCarryFlag diff
       .|. subtractionFlag
       .|. testHalfCarryFlag x1 x2 res
  res = diff .&. 255
  diff = x1 - x2

-- Boolean operations
-- ==================

--AND A,R
andOpRegIntoA :: GetReg -> Regs -> Regs
andOpRegIntoA = boolOpRegIntoA (.&.)

--OR A,R
orOpRegIntoA :: GetReg -> Regs -> Regs
orOpRegIntoA = boolOpRegIntoA (.|.)

--XOR A,R
xorOpRegIntoA :: GetReg -> Regs -> Regs
xorOpRegIntoA = boolOpRegIntoA (.^.)

boolOpRegIntoA :: (I8 -> I8 -> I8) -> GetReg -> Regs -> Regs
boolOpRegIntoA op getReg regs = boolOpXIntoA op (getReg regs) regs

--AND A,(HL)
andOpHLMemIntoA :: Mem -> Regs
andOpHLMemIntoA = boolOpHlMemIntoA (.&.)

--OR A,(HL)
orOpHLMemIntoA :: Mem -> Regs
orOpHLMemIntoA = boolOpHlMemIntoA (.|.)

--XOR A,(HL)
xorOpHLMemIntoA :: Mem -> Regs
xorOpHLMemIntoA = boolOpHlMemIntoA (.^.)

boolOpHlMemIntoA  :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpHlMemIntoA op { mainMem, regs } =
  (boolOpXIntoA op hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--AND A,Imm
andOpImmIntoA :: Mem -> Regs
andOpImmIntoA  = boolOpImmIntoA (.&.)

--OR A,Imm
orOpImmIntoA :: Mem -> Regs
orOpImmIntoA = boolOpImmIntoA (.|.)

--XOR A,Imm
xorOpImmIntoA :: Mem -> Regs
xorOpImmIntoA = boolOpImmIntoA (.^.)

boolOpImmIntoA :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpImmIntoA op { mainMem, regs } =
  (boolOpXIntoA op imm regs) {pc = regs.pc + 1, m = 2}
 where imm = rd8 regs.pc mainMem

boolOpXIntoA :: (I8 -> I8 -> I8) -> I8 -> Regs -> Regs
boolOpXIntoA op x regs =
  regs { a = a', f = testZeroFlag a', m = 1 }
 where a' = (regs.a `op` x) .&. 255

-- Bit operations
-- ==============

--CPL
cmplA :: Regs -> Regs
cmplA regs = regs { a = a', f = testZeroFlag a' ,m = 1 }
 where a' = 255 .^. regs.a

--BIT N,R
testBitNOfReg :: I8 -> GetReg -> Regs -> Regs
testBitNOfReg n getReg regs = testBitNOfX n (getReg regs) regs

--BIT N,(HL)
testBitNOfHLMem :: I8 -> Mem -> Regs
testBitNOfHLMem n { mainMem, regs } =
  (testBitNOfX n hlMem regs) { m = 3 }
 where
  hlMem = rd8 (joinRegs h l regs) mainMem

testBitNOfX :: Int -> I8 -> Regs -> Regs
testBitNOfX n x regs = regs { f = f', m = 2 }
 where
  f' =  setZeroFlag bitTest
     $  halfCarryFlag
    .|. (regs.f .&. carryFlag) -- NOTE: should it be 0x1F instead?
  bitTest = x .&. (1 `shl` n)

--SET N,R
--RES N,R
setBitNOfReg :: Boolean -> Int -> SetReg -> GetReg
               -> Regs -> Regs
setBitNOfReg setVal n setReg getReg regs = setReg reg' regs { m = 2 }
 where reg' = setBitNOfX setVal n (getReg regs)

--SET N,(HL)
--RES N,(HL)
setBitNOfHLMem :: Boolean -> Int -> Mem -> Mem
setBitNOfHLMem setVal n mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { m = 4 } }
 where
  mainMem' = wr8 hl' addr mainMem
  hl' = setBitNOfX setVal n $ rd8 addr mainMem
  addr = joinRegs h l regs

setBitNOfX :: Boolean -> Int -> I8 -> I8
setBitNOfX setVal n x = if setVal
  then x .|. bitShift
  else x .&. complement bitShift
 where bitShift = 1 `shl` n

-- Rotations
-- =========

data Dir = Left | Right
derive instance eqDir :: Eq Dir

-- RL[C] A, base-opcode
-- RR[C] A, base-opcode
rotA :: Dir -> Boolean -> Regs -> Regs
rotA dir isCarryRot regs = regs { a = rotated.res, f = rotated.flags, m = 1 }
 where rotated = rotX {dir,isCarryRot,isCB:false} regs.a regs.f

-- RL[C] R, CB-prefix instruction
-- RR[C] R, CB-prefix instruction
rotReg :: Dir -> Boolean -> SetReg -> GetReg -> Regs -> Regs
rotReg dir isCarryRot setReg getReg regs =
  setReg rotated.res regs { f = rotated.flags, m = 2 }
 where rotated = rotX {dir,isCarryRot,isCB:true} (getReg regs) regs.f

-- RL[C] (HL)
-- RR[C] (HL)
rotHLMem :: Dir -> Boolean -> Mem -> Mem
rotHLMem dir isCarryRot mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = rotated.flags, m = 4 } }
 where
  mainMem' = wr8 rotated.res addr mainMem
  addr = joinRegs h l regs
  rotated = rotX {dir,isCarryRot,isCB:true} (rd8 addr mainMem) regs.f

rotX :: {dir::Dir,isCarryRot::Boolean,isCB::Boolean}
      -> I8 -> I8 -> { res :: I8, flags :: I8 }
rotX { dir, isCarryRot, isCB } x oldFlags = { res, flags }
 where
  res = 255 .&. (currCarry + (x `shiftFunc` 1))
  -- RotA basic, use old flags, RotR CB, start fresh with zeroFlag
  flags = setNewCarry
    $ if isCB then testZeroFlag res else oldFlags
  currCarry = if   (not isCarryRot) && (oldFlags .&. carryFlag /= 0)
                || (isCarryRot      && isNewCarry)
    then case dir of
      Left -> 1
      Right -> 0x80
    else 0
  setNewCarry = if isNewCarry
    then (carryFlag .|. _)
    else (cmplCarryFlag .&. _)
  isNewCarry = x .&. edgeBit /= 0
  edgeBit = case dir of
    Left -> 0x80
    Right -> 1
  shiftFunc = case dir of
    Left -> shl
    Right -> zshr

-- Shifts
-- ======

--SLA R
--SRA R preserve sign
--SRL R
shiftReg :: Dir -> Boolean -> SetReg -> GetReg
         -> Regs -> Regs
shiftReg dir sign setReg getReg regs =
  setReg shifted.res regs { f = shifted.flags, m = 2 }
 where
  shifted = shiftX dir sign $ getReg regs

shiftMemHL :: Dir -> Boolean -> Mem -> Mem
shiftMemHL dir sign mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = shifted.flags, m = 4 } }
 where
  mainMem' = wr8 shifted.res addr mainMem
  shifted = shiftX dir sign $ rd8 addr mainMem
  addr = joinRegs h l regs

shiftX :: Dir -> Boolean -> I8
       -> { res::I8, flags::I8 }
shiftX dir sign x = { res, flags }
 where
  res =  (255 .&. _)
     <<< (if sign && dir == Right then (currCarry + _) else id)
      $  x `shiftFunc` 1
  shiftFunc = case dir of
    Left -> shl
    Right -> zshr
  flags = newCarry .|. testZeroFlag res
  newCarry = if x .&. edgeBit /= 0 then carryFlag else 0
  currCarry = x .&. 0x80 --sign is only relevant for right shifts
  edgeBit = case dir of
    Left -> 0x80
    Right -> 1

-- Increments / Decrements
-- =======================

--INC R
incReg :: GetReg -> SetReg -> Regs -> Regs
incReg = incDecReg incI8

--DEC R
decReg :: GetReg -> SetReg -> Regs -> Regs
decReg = incDecReg decI8

incDecReg :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> SetReg -> Regs -> Regs
incDecReg op getReg setReg regs =
  setReg inced .res regs {f = testZeroFlag inced.res, m = 1}
 where
  inced  = op $ getReg regs

--INC RR
incRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
incRegWithCarry = incDecRegWithCarry incI8

--DEC RR
decRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
decRegWithCarry = incDecRegWithCarry decI8

--NOTE: consider refactoring to something along the lines of
--"split2Regs . incI16 . joinRegs", if you have leeway, performance-wise.
incDecRegWithCarry :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> GetReg -> SetReg -> SetReg
          -> Regs -> Regs
incDecRegWithCarry op getCarryReg getMainReg setCarryReg setMainReg regs =
  setCarryReg carryReg' <<< setMainReg mainReg' $ regs{m = 1}
 where
  carryReg' = (if mainRegInc.carry then _.res <<< op else id)
    $ getCarryReg regs
  mainReg' = mainRegInc.res
  mainRegInc = op $ getMainReg regs

--INC SP
incSP :: Regs -> Regs
incSP = incDecSP $ \x -> 0xFFFF .&. (x + 1)

--DEC SP
decSP :: Regs -> Regs
decSP = incDecSP $ \x -> 0xFFFF .&. (x - 1)

incDecSP :: (I16 -> I16) -> Regs -> Regs
incDecSP op regs = regs {sp = op $ regs.sp, m = 1}

--INC (HL)
incHLMem :: Mem -> Mem
incHLMem = incDecHLMem incI8

--DEC (HL)
decHLMem :: Mem -> Mem
decHLMem = incDecHLMem decI8

incDecHLMem :: (I8 -> { res :: I8, carry :: Boolean })
            -> Mem -> Mem
incDecHLMem op mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs {f = testZeroFlag inced.res, m = 3} }
 where
  mainMem' = wr8 inced.res addr mainMem
  inced = op $ rd8 addr mainMem
  addr = joinRegs h l regs

incI8 :: I8 -> { res :: I8, carry :: Boolean }
incI8 i8 = { res : i8', carry : i8' == 0 }
 where
  i8' = (i8 + 1) .&. 255

decI8 :: I8 -> { res :: I8, carry :: Boolean }
decI8 i8 = { res : i8', carry : i8' == 255 }
 where
  i8' = (i8 - 1) .&. 255

-- Loads
-- =====

--LD R,R
ldRegFromReg :: SetReg -> GetReg
      -> Regs -> Regs
ldRegFromReg setDestReg getSrcReg regs = setDestReg (getSrcReg regs)
  regs { m = 1 }

--LD (nn),SP
ldMemImmFromSP :: Mem -> Mem
ldMemImmFromSP mem@{mainMem, regs} =
  mem { mainMem = mainMem', regs = regs { pc = regs.pc + 2, m = 5 } }
 where
  mainMem' = wr16 regs.sp addr mainMem
  addr = rd16 regs.pc mainMem

--LD SP,HL
ldSPFromHL :: Regs -> Regs
ldSPFromHL regs  =
  regs { sp = sp', m = 2 }
 where sp' = joinRegs h l regs

ldSPFromImm :: Mem -> Regs
ldSPFromImm { mainMem, regs } =
  regs { sp = sp', pc = regs.pc + 2, m = 3 }
 where sp' = rd16 regs.pc mainMem

--LD RR,nn
ldTwoRegsFromImm :: SetReg -> SetReg
               -> Mem -> Regs
ldTwoRegsFromImm setReg1 setReg2 mem = regs'' { m = 3 }
 where
  regs'  = ldRegFromImm setReg2 mem
  regs'' = ldRegFromImm setReg1 mem { regs = regs' }

--LD R,(IOC)
ldRegFromFF00CMem :: SetReg -> Mem -> Regs
ldRegFromFF00CMem setReg mem@{regs, mainMem} = regs' { m = 2 }
 where regs' = ldRegFromFF00PlusX regs.c setReg mem

--LD R,(IOn)
ldRegFromFF00ImmMem :: SetReg -> Mem -> Regs
ldRegFromFF00ImmMem setReg mem@{regs, mainMem} = regs' { pc = regs.pc + 1, m = 3 }
 where regs' = ldRegFromFF00PlusX (rd8 regs.pc mainMem) setReg mem

ldRegFromFF00PlusX :: I8 -> SetReg -> Mem -> Regs
ldRegFromFF00PlusX  x setReg mem@{regs} = ldRegFromMem setReg addr mem
 where addr = 0xFF00 + x

--LD R,n
ldRegFromImm :: SetReg -> Mem -> Regs
ldRegFromImm setReg mem@{regs} = regs' { pc = regs.pc + 1 }
  where regs' = ldRegFromMem setReg regs.pc mem

--LD R,(RR)
ldRegFromMem2R :: SetReg -> GetReg -> GetReg
               -> Mem -> Regs
ldRegFromMem2R setReg msByteReg lsByteReg mem@{regs} =
  ldRegFromMem setReg ((msByteReg regs `shl` 8) + lsByteReg regs) mem

--LD A,(nn)
ldRegAFromMemImm :: Mem -> Regs
ldRegAFromMemImm mem@{ mainMem, regs } = regs' { pc = regs.pc + 2, m = 4 }
 where
  regs' = ldRegFromMem setA addr mem
  addr = rd16 regs.pc mainMem

--LDD A,(HL)
ldRegFromMemHLDec :: SetReg -> Mem -> Regs
ldRegFromMemHLDec = ldRegFromMemHLIncDec decRegWithCarry

--LDI A,(HL)
ldRegFromMemHLInc :: SetReg -> Mem -> Regs
ldRegFromMemHLInc = ldRegFromMemHLIncDec incRegWithCarry

ldRegFromMemHLIncDec :: (GetReg -> GetReg -> SetReg -> SetReg -> Regs -> Regs)
                   -- Inc/Dec reg operation's type signature
                   -> SetReg -> Mem -> Regs
ldRegFromMemHLIncDec op setReg mem@{ regs } = regs' {m = 2}
 where
  regs' = op h l setH setL
        $ ldRegFromMem setA addr mem
  addr = joinRegs h l regs

ldRegFromMem :: SetReg -> I16 -> Mem -> Regs
ldRegFromMem setReg addr { mainMem, regs } =
  setReg (rd8 addr mainMem) regs{m = 2}

--LD HL,SP|n|
ldHLFromSPImm :: Mem -> Regs
ldHLFromSPImm  mem@{ regs, mainMem } =
  regs {h = split.ms, l = split.ls, pc = regs.pc + 1, m = 3}
 where
  split = splitI16 x
  x = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 regs.pc mainMem

--LDI (HL),A
ldMemHLFromRegInc :: GetReg -> Mem -> Mem
ldMemHLFromRegInc = ldMemHLFromRegIncDec incRegWithCarry

--LDD (HL),A
ldMemHLFromRegDec :: GetReg -> Mem -> Mem
ldMemHLFromRegDec  = ldMemHLFromRegIncDec decRegWithCarry

ldMemHLFromRegIncDec :: (GetReg -> GetReg -> SetReg -> SetReg -> Regs -> Regs)
                   -- Inc/Dec reg operation's type signature
                   -> GetReg
                   -> Mem -> Mem
ldMemHLFromRegIncDec op getReg mem@{regs} =
  mem { mainMem = mainMem', regs = regs' {m = 2} }
 where
  regs' = op h l setH setL regs
  mainMem' = _.mainMem $ ldMemFromReg addr a mem
  addr = joinRegs h l regs

--LD (IOC),R
ldFF00CMemFromReg :: GetReg -> Mem -> Mem
ldFF00CMemFromReg getReg mem@{regs, mainMem} =
  mem' { regs = regs{m = 2} }
 where mem' = ldFF00PlusXFromReg  regs.c getReg mem

--LD (IOn),R
ldFF00ImmMemFromReg :: GetReg -> Mem -> Mem
ldFF00ImmMemFromReg getReg mem@{regs, mainMem} =
  mem' { regs = regs{pc = regs.pc + 1, m = 3} }
 where mem' = ldFF00PlusXFromReg  (rd8 regs.pc mainMem) getReg mem

ldFF00PlusXFromReg :: I8 -> GetReg -> Mem -> Mem
ldFF00PlusXFromReg   x getReg mem@{regs, mainMem} = mem'
 where
  mem' = ldMemFromReg addr getReg mem
  addr = 0xFF00 + x

--LD (nn),A
ldMemImmFromRegA :: Mem -> Mem
ldMemImmFromRegA  mem@{ mainMem, regs } =
 mem' { regs = regs{m = 4, pc = regs.pc + 2} }
 where
  mem' = ldMemFromReg addr a mem
  addr = rd16 regs.pc mainMem

--LD (HL),n
ldMemHLFromImm :: Mem -> Mem
ldMemHLFromImm  mem@{mainMem,regs} =
  mem { mainMem = mainMem' , regs = regs{m = 3, pc = regs.pc + 1} }
 where
  mainMem' = wr8 (rd8 regs.pc mainMem) addr mainMem
  addr =  joinRegs h l regs

--LD (RR),R
ldMem2RFromReg :: GetReg -> GetReg -> GetReg
                        -> Mem -> Mem
ldMem2RFromReg msbAddrReg lsbAddrReg getReg mem@{ regs } =
  ldMemFromReg (joinRegs msbAddrReg lsbAddrReg regs) getReg mem

ldMemFromReg :: I16 -> GetReg
           -> Mem -> Mem
ldMemFromReg addr getReg mem@{ regs } = ldMemFromX addr (getReg regs) mem

ldMemFromX :: I16 -> I8
           -> Mem -> Mem
ldMemFromX addr x mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs{m = 2} }
 where mainMem' = wr8 x addr mainMem

-- Compares
-- ========

--CP A,R
compAToReg :: GetReg -> Regs -> Regs
compAToReg getReg regs = compAToX (getReg regs) regs

--CP A,(HL)
compAToMemHL :: Mem -> Regs
compAToMemHL { mainMem, regs } = (compAToX hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--CP A,n
compAToImm :: Mem -> Regs
compAToImm { mainMem, regs } = (compAToX imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

compAToX :: I8 -> Regs -> Regs
compAToX x regs = regs { f = diff.flags, m = 1 }
 where
  diff = subI8s regs.a x

-- Helpers
-- =======

saveRegs :: Regs -> SavedRegs -> SavedRegs
saveRegs regs svdRegs =
  svdRegs { a = regs.a, b = regs.b, c = regs.c, d = regs.d
          , e = regs.e, f = regs.f, h = regs.h, l = regs.l
          }

restoreRegs :: SavedRegs -> Regs -> Regs
restoreRegs svdRegs regs =
  regs { a = svdRegs.a, b = svdRegs.b, c = svdRegs.c, d = svdRegs.d
       , e = svdRegs.e, f = svdRegs.f, h = svdRegs.h, l = svdRegs.l
       }

joinRegs :: GetReg -> GetReg -> Regs -> I16
joinRegs msByteReg lsByteReg regs = (msByteReg regs `shl` 8) + lsByteReg regs

absI8 :: I8 -> I8
absI8 i8 = if i8 > 127 then negI8 i8 else i8

negI8 :: I8 -> I8
negI8 i8 = (complement i8 + 1) .&. 255

splitI16 :: I16 -> { ms :: I8, ls :: I8 }
splitI16 x = { ms : (x `zshr` 8) .&. 255
             , ls : x .&. 255
             }

isSetFlag :: I8 -> I8 -> Boolean
isSetFlag f fs = f .&. fs /= 0

setFlag :: I8 -> I8 -> I8
setFlag  f = (f .|. _)

unsetFlag :: I8 -> I8 -> I8
unsetFlag f = ((complement f) .&. _)

flipFlag :: I8 -> I8 -> I8
flipFlag f = (f .^. _)

testZeroFlag :: Int -> Int
testZeroFlag x = if x == 0 then 0x80 else 0

setZeroFlag :: Int -> I8 -> I8
setZeroFlag x = if x == 0
  then (_ .|. zeroFlag)
  else (_ .&. cmplZeroFlag)

testCarryFlag8 :: Int -> I8
testCarryFlag8 x = if x > 255 then carryFlag else 0

setCarryFlag16 :: Int -> I8 -> I8
setCarryFlag16 x = if x > 0xFFFF
  then (_ .|. carryFlag)
  else (_ .&. cmplCarryFlag)

testNegCarryFlag :: Int -> I8
testNegCarryFlag reg = if reg < 0 then carryFlag else 0

testHalfCarryFlag :: I8 -> I8 -> I8 -> I8
testHalfCarryFlag reg1 reg2 sum = if res /= 0 then halfCarryFlag else 0
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

setHalfCarryFlag :: I8 -> I8 -> I8 -> I8 -> I8
setHalfCarryFlag reg1 reg2 sum =
  if res /= 0 then (_ .|. halfCarryFlag) else (_ .&. cmplHalfCarryFlag)
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

xor :: Boolean -> Boolean -> Boolean
xor true x = not x
xor false x = x

zeroFlag :: I8
zeroFlag = 0x80
cmplZeroFlag :: I8
cmplZeroFlag = 0x7F
carryFlag :: I8
carryFlag = 0x10
cmplCarryFlag :: I8
cmplCarryFlag = 0xEF
halfCarryFlag :: I8
halfCarryFlag = 0x20
cmplHalfCarryFlag :: I8
cmplHalfCarryFlag = 0xD0
subtractionFlag :: I8
subtractionFlag = 0x40

type GetReg = Regs -> I8
type SetReg = I8 -> Regs -> Regs

module Ops where

import Prelude
import Data.Int.Bits
import Data.Maybe
import Data.Array ((!!)) as A

import Types
import MainMem

--NOTE: consider moving the timings to 2D arrays.
--separate from the opcode's logic

-- Additions
-- =========

--ADD A,R
addRegToA :: GetReg -> Regs -> Regs
addRegToA getReg regs = addXToA (getReg regs) regs

--ADD A,(HL)
addHLMemToA :: Mem -> Regs
addHLMemToA { mainMem, regs } = (addXToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADD A,n
addImmToA :: Mem -> Regs
addImmToA { mainMem, regs } =
  (addXToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

addXToA :: I8 -> Regs -> Regs
addXToA x regs =
  regs {a = sum.res, f = sum.flags, m = 1}
 where sum = addI8s regs.a x

--ADC A,R
addRegCarryToA :: GetReg -> Regs -> Regs
addRegCarryToA getReg regs = addXCarryToA (getReg regs) regs

--ADC A,(HL)
addHLMemCarryToA :: Mem -> Regs
addHLMemCarryToA { mainMem, regs } = (addXCarryToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADC A,n
addImmCarryToA :: Mem -> Regs
addImmCarryToA { mainMem, regs } =
  (addXCarryToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
addXCarryToA :: I8 -> Regs -> Regs
addXCarryToA x regs =
  regs {a = sum.res, f = f', m = 1}
 where
  --Overriding addI8's half-carry flag because it used regs.a+carry
  --Which is essential for the other flags, but not for this one.
  f' = setHalfCarryFlag x regs.a sum.res sum.flags
  sum = addI8s (regs.a + carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

--ADD SP,|n|
addImmToSP :: Mem -> Regs
addImmToSP { regs, mainMem } =
  regs {sp = sp', pc = regs.pc + 1, m = 4}
 where
  sp' = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 regs.pc mainMem

addI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
addI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testCarryFlag8 sum
       .|. testHalfCarryFlag x1 x2 res
  res = sum .&. 255
  sum = x1 + x2

--ADD HL,RR
add2RegsToHL :: GetReg -> GetReg -> Regs -> Regs
add2RegsToHL msByteReg lsByteReg regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl joinedRegs regs.f
  joinedRegs = joinRegs msByteReg lsByteReg regs
  hl = joinRegs h l regs

--ADD HL,SP
addSPToHL :: Regs -> Regs
addSPToHL regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl regs.sp regs.f
  hl = joinRegs h l regs

addI16s :: I8 -> I16 -> I16 -> { res :: I16, flags :: I8 }
addI16s oldFlags x1 x2 = { res, flags }
 where
  flags =  setCarryFlag16 sum
        $  oldFlags
       .|. testZeroFlag res
  res = sum .&. 0xFFFF
  sum = x1 + x2

-- Subtractions
-- ============

--SUB A,R
subRegFromA :: GetReg -> Regs -> Regs
subRegFromA getReg regs = subXFromA (getReg regs) regs

--SUB A,(HL)
subHLMemFromA :: Mem -> Regs
subHLMemFromA { mainMem, regs } = (subXFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SUB A,n
subImmFromA :: Mem -> Regs
subImmFromA { mainMem, regs } = (subXFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Subtractions and additions are relatively similar. Consider
--Using same functions for both, if it doesn't obfuscate much.
subXFromA :: I8 -> Regs -> Regs
subXFromA x regs =
  regs {a = diff.res, f = diff.flags, m = 1}
 where diff = subI8s regs.a x

--SBC A,R
subRegCarryFromA :: GetReg -> Regs -> Regs
subRegCarryFromA getReg regs = subXCarryFromA (getReg regs) regs

--SBC A,(HL)
subHLMemCarryFromA :: Mem -> Regs
subHLMemCarryFromA { mainMem, regs } = (subXCarryFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SBC A,n
subImmCarryToA :: Mem -> Regs
subImmCarryToA { mainMem, regs } = (subXCarryFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
subXCarryFromA :: I8 -> Regs -> Regs
subXCarryFromA x regs =
  regs {a = diff.res, f = f', m = 1}
 where
  f' = setHalfCarryFlag x regs.a diff.res diff.flags
  diff = subI8s (regs.a - carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

subI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
subI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testNegCarryFlag diff
       .|. subtractionFlag
       .|. testHalfCarryFlag x1 x2 res
  res = diff .&. 255
  diff = x1 - x2

-- Boolean operations
-- ==================

--AND A,R
andOpRegIntoA :: GetReg -> Regs -> Regs
andOpRegIntoA = boolOpRegIntoA (.&.)

--OR A,R
orOpRegIntoA :: GetReg -> Regs -> Regs
orOpRegIntoA = boolOpRegIntoA (.|.)

--XOR A,R
xorOpRegIntoA :: GetReg -> Regs -> Regs
xorOpRegIntoA = boolOpRegIntoA (.^.)

boolOpRegIntoA :: (I8 -> I8 -> I8) -> GetReg -> Regs -> Regs
boolOpRegIntoA op getReg regs = boolOpXIntoA op (getReg regs) regs

--AND A,(HL)
andOpHLMemIntoA :: Mem -> Regs
andOpHLMemIntoA = boolOpHlMemIntoA (.&.)

--OR A,(HL)
orOpHLMemIntoA :: Mem -> Regs
orOpHLMemIntoA = boolOpHlMemIntoA (.|.)

--XOR A,(HL)
xorOpHLMemIntoA :: Mem -> Regs
xorOpHLMemIntoA = boolOpHlMemIntoA (.^.)

boolOpHlMemIntoA  :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpHlMemIntoA op { mainMem, regs } =
  (boolOpXIntoA op hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--AND A,Imm
andOpImmIntoA :: Mem -> Regs
andOpImmIntoA  = boolOpImmIntoA (.&.)

--OR A,Imm
orOpImmIntoA :: Mem -> Regs
orOpImmIntoA = boolOpImmIntoA (.|.)

--XOR A,Imm
xorOpImmIntoA :: Mem -> Regs
xorOpImmIntoA = boolOpImmIntoA (.^.)

boolOpImmIntoA :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpImmIntoA op { mainMem, regs } =
  (boolOpXIntoA op imm regs) {pc = regs.pc + 1, m = 2}
 where imm = rd8 regs.pc mainMem

boolOpXIntoA :: (I8 -> I8 -> I8) -> I8 -> Regs -> Regs
boolOpXIntoA op x regs =
  regs { a = a', f = testZeroFlag a', m = 1 }
 where a' = (regs.a `op` x) .&. 255

-- Bit operations
-- ==============

--CPL
cmplA :: Regs -> Regs
cmplA regs = regs { a = a', f = testZeroFlag a' ,m = 1 }
 where a' = 255 .^. regs.a

--BIT N,R
testBitNOfReg :: I8 -> GetReg -> Regs -> Regs
testBitNOfReg n getReg regs = testBitNOfX n (getReg regs) regs

--BIT N,(HL)
testBitNOfHLMem :: I8 -> Mem -> Regs
testBitNOfHLMem n { mainMem, regs } =
  (testBitNOfX n hlMem regs) { m = 3 }
 where
  hlMem = rd8 (joinRegs h l regs) mainMem

testBitNOfX :: Int -> I8 -> Regs -> Regs
testBitNOfX n x regs = regs { f = f', m = 2 }
 where
  f' =  setZeroFlag bitTest
     $  halfCarryFlag
    .|. (regs.f .&. carryFlag) -- NOTE: should it be 0x1F instead?
  bitTest = x .&. (1 `shl` n)

--SET N,R
--RES N,R
setBitNOfReg :: Boolean -> Int -> SetReg -> GetReg
               -> Regs -> Regs
setBitNOfReg setVal n setReg getReg regs = setReg reg' regs { m = 2 }
 where reg' = setBitNOfX setVal n (getReg regs)

--SET N,(HL)
--RES N,(HL)
setBitNOfHLMem :: Boolean -> Int -> Mem -> Mem
setBitNOfHLMem setVal n mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { m = 4 } }
 where
  mainMem' = wr8 hl' addr mainMem
  hl' = setBitNOfX setVal n $ rd8 addr mainMem
  addr = joinRegs h l regs

setBitNOfX :: Boolean -> Int -> I8 -> I8
setBitNOfX setVal n x = if setVal
  then x .|. bitShift
  else x .&. complement bitShift
 where bitShift = 1 `shl` n

-- Rotations
-- =========

data Dir = Left | Right
derive instance eqDir :: Eq Dir

-- RL[C] A, base-opcode
-- RR[C] A, base-opcode
rotA :: Dir -> Boolean -> Regs -> Regs
rotA dir isCarryRot regs = regs { a = rotated.res, f = rotated.flags, m = 1 }
 where rotated = rotX {dir,isCarryRot,isCB:false} regs.a regs.f

-- RL[C] R, CB-prefix instruction
-- RR[C] R, CB-prefix instruction
rotReg :: Dir -> Boolean -> SetReg -> GetReg -> Regs -> Regs
rotReg dir isCarryRot setReg getReg regs =
  setReg rotated.res regs { f = rotated.flags, m = 2 }
 where rotated = rotX {dir,isCarryRot,isCB:true} (getReg regs) regs.f

-- RL[C] (HL)
-- RR[C] (HL)
rotHLMem :: Dir -> Boolean -> Mem -> Mem
rotHLMem dir isCarryRot mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = rotated.flags, m = 4 } }
 where
  mainMem' = wr8 rotated.res addr mainMem
  addr = joinRegs h l regs
  rotated = rotX {dir,isCarryRot,isCB:true} (rd8 addr mainMem) regs.f

rotX :: {dir::Dir,isCarryRot::Boolean,isCB::Boolean}
      -> I8 -> I8 -> { res :: I8, flags :: I8 }
rotX { dir, isCarryRot, isCB } x oldFlags = { res, flags }
 where
  res = 255 .&. (currCarry + (x `shiftFunc` 1))
  -- RotA basic, use old flags, RotR CB, start fresh with zeroFlag
  flags = setNewCarry
    $ if isCB then testZeroFlag res else oldFlags
  currCarry = if   (not isCarryRot) && (oldFlags .&. carryFlag /= 0)
                || (isCarryRot      && isNewCarry)
    then case dir of
      Left -> 1
      Right -> 0x80
    else 0
  setNewCarry = if isNewCarry
    then (carryFlag .|. _)
    else (cmplCarryFlag .&. _)
  isNewCarry = x .&. edgeBit /= 0
  edgeBit = case dir of
    Left -> 0x80
    Right -> 1
  shiftFunc = case dir of
    Left -> shl
    Right -> zshr

-- Shifts
-- ======

--SLA R
--SRA R preserve sign
--SRL R
shiftReg :: Dir -> Boolean -> SetReg -> GetReg
         -> Regs -> Regs
shiftReg dir sign setReg getReg regs =
  setReg shifted.res regs { f = shifted.flags, m = 2 }
 where
  shifted = shiftX dir sign $ getReg regs

shiftMemHL :: Dir -> Boolean -> Mem -> Mem
shiftMemHL dir sign mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = shifted.flags, m = 4 } }
 where
  mainMem' = wr8 shifted.res addr mainMem
  shifted = shiftX dir sign $ rd8 addr mainMem
  addr = joinRegs h l regs

shiftX :: Dir -> Boolean -> I8
       -> { res::I8, flags::I8 }
shiftX dir sign x = { res, flags }
 where
  res =  (255 .&. _)
     <<< (if sign && dir == Right then (currCarry + _) else id)
      $  x `shiftFunc` 1
  shiftFunc = case dir of
    Left -> shl
    Right -> zshr
  flags = newCarry .|. testZeroFlag res
  newCarry = if x .&. edgeBit /= 0 then carryFlag else 0
  currCarry = x .&. 0x80 --sign is only relevant for right shifts
  edgeBit = case dir of
    Left -> 0x80
    Right -> 1

-- Increments / Decrements
-- =======================

--INC R
incReg :: GetReg -> SetReg -> Regs -> Regs
incReg = incDecReg incI8

--DEC R
decReg :: GetReg -> SetReg -> Regs -> Regs
decReg = incDecReg decI8

incDecReg :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> SetReg -> Regs -> Regs
incDecReg op getReg setReg regs =
  setReg inced .res regs {f = testZeroFlag inced.res, m = 1}
 where
  inced  = op $ getReg regs

--INC RR
incRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
incRegWithCarry = incDecRegWithCarry incI8

--DEC RR
decRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
decRegWithCarry = incDecRegWithCarry decI8

--NOTE: consider refactoring to something along the lines of
--"split2Regs . incI16 . joinRegs", if you have leeway, performance-wise.
incDecRegWithCarry :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> GetReg -> SetReg -> SetReg
          -> Regs -> Regs
incDecRegWithCarry op getCarryReg getMainReg setCarryReg setMainReg regs =
  setCarryReg carryReg' <<< setMainReg mainReg' $ regs{m = 1}
 where
  carryReg' = (if mainRegInc.carry then _.res <<< op else id)
    $ getCarryReg regs
  mainReg' = mainRegInc.res
  mainRegInc = op $ getMainReg regs

--INC SP
incSP :: Regs -> Regs
incSP = incDecSP $ \x -> 0xFFFF .&. (x + 1)

--DEC SP
decSP :: Regs -> Regs
decSP = incDecSP $ \x -> 0xFFFF .&. (x - 1)

incDecSP :: (I16 -> I16) -> Regs -> Regs
incDecSP op regs = regs {sp = op $ regs.sp, m = 1}

--INC (HL)
incHLMem :: Mem -> Mem
incHLMem = incDecHLMem incI8

--DEC (HL)
decHLMem :: Mem -> Mem
decHLMem = incDecHLMem decI8

incDecHLMem :: (I8 -> { res :: I8, carry :: Boolean })
            -> Mem -> Mem
incDecHLMem op mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs {f = testZeroFlag inced.res, m = 3} }
 where
  mainMem' = wr8 inced.res addr mainMem
  inced = op $ rd8 addr mainMem
  addr = joinRegs h l regs

incI8 :: I8 -> { res :: I8, carry :: Boolean }
incI8 i8 = { res : i8', carry : i8' == 0 }
 where
  i8' = (i8 + 1) .&. 255

decI8 :: I8 -> { res :: I8, carry :: Boolean }
decI8 i8 = { res : i8', carry : i8' == 255 }
 where
  i8' = (i8 - 1) .&. 255

-- Compares
-- ========

--CP A,R
compAToReg :: GetReg -> Regs -> Regs
compAToReg getReg regs = compAToX (getReg regs) regs

--CP A,(HL)
compAToMemHL :: Mem -> Regs
compAToMemHL { mainMem, regs } = (compAToX hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--CP A,n
compAToImm :: Mem -> Regs
compAToImm { mainMem, regs } = (compAToX imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

compAToX :: I8 -> Regs -> Regs
compAToX x regs = regs { f = diff.flags, m = 1 }
 where
  diff = subI8s regs.a x

-- Helpers
-- =======

saveRegs :: Regs -> SavedRegs -> SavedRegs
saveRegs regs svdRegs =
  svdRegs { a = regs.a, b = regs.b, c = regs.c, d = regs.d
          , e = regs.e, f = regs.f, h = regs.h, l = regs.l
          }

restoreRegs :: SavedRegs -> Regs -> Regs
restoreRegs svdRegs regs =
  regs { a = svdRegs.a, b = svdRegs.b, c = svdRegs.c, d = svdRegs.d
       , e = svdRegs.e, f = svdRegs.f, h = svdRegs.h, l = svdRegs.l
       }

joinRegs :: GetReg -> GetReg -> Regs -> I16
joinRegs msByteReg lsByteReg regs = (msByteReg regs `shl` 8) + lsByteReg regs

absI8 :: I8 -> I8
absI8 i8 = if i8 > 127 then negI8 i8 else i8

negI8 :: I8 -> I8
negI8 i8 = (complement i8 + 1) .&. 255

splitI16 :: I16 -> { ms :: I8, ls :: I8 }
splitI16 x = { ms : (x `zshr` 8) .&. 255
             , ls : x .&. 255
             }

isSetFlag :: I8 -> I8 -> Boolean
isSetFlag f fs = f .&. fs /= 0

setFlag :: I8 -> I8 -> I8
setFlag  f = (f .|. _)

unsetFlag :: I8 -> I8 -> I8
unsetFlag f = ((complement f) .&. _)

flipFlag :: I8 -> I8 -> I8
flipFlag f = (f .^. _)

testZeroFlag :: Int -> Int
testZeroFlag x = if x == 0 then 0x80 else 0

setZeroFlag :: Int -> I8 -> I8
setZeroFlag x = if x == 0
  then (_ .|. zeroFlag)
  else (_ .&. cmplZeroFlag)

testCarryFlag8 :: Int -> I8
testCarryFlag8 x = if x > 255 then carryFlag else 0

setCarryFlag16 :: Int -> I8 -> I8
setCarryFlag16 x = if x > 0xFFFF
  then (_ .|. carryFlag)
  else (_ .&. cmplCarryFlag)

testNegCarryFlag :: Int -> I8
testNegCarryFlag reg = if reg < 0 then carryFlag else 0

testHalfCarryFlag :: I8 -> I8 -> I8 -> I8
testHalfCarryFlag reg1 reg2 sum = if res /= 0 then halfCarryFlag else 0
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

setHalfCarryFlag :: I8 -> I8 -> I8 -> I8 -> I8
setHalfCarryFlag reg1 reg2 sum =
  if res /= 0 then (_ .|. halfCarryFlag) else (_ .&. cmplHalfCarryFlag)
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

xor :: Boolean -> Boolean -> Boolean
xor true x = not x
xor false x = x

zeroFlag :: I8
zeroFlag = 0x80
cmplZeroFlag :: I8
cmplZeroFlag = 0x7F
carryFlag :: I8
carryFlag = 0x10
cmplCarryFlag :: I8
cmplCarryFlag = 0xEF
halfCarryFlag :: I8
halfCarryFlag = 0x20
cmplHalfCarryFlag :: I8
cmplHalfCarryFlag = 0xD0
subtractionFlag :: I8
subtractionFlag = 0x40

type GetReg = Regs -> I8
type SetReg = I8 -> Regs -> Regs


export `activeElement`

export `activeElement`

module DOM.HTML.Document
  ( body
  , readyState
  , activeElement
  , module Exports
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML.Document.ReadyState (ReadyState(..)) as Exports
import DOM.HTML.Document.ReadyState (ReadyState, parseReadyState)
import DOM.HTML.Types (HTMLElement, HTMLDocument)
import Data.Maybe (Maybe, fromJust)
import Data.Nullable (Nullable, toMaybe)
import Partial.Unsafe (unsafePartial)

foreign import _body :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Nullable HTMLElement)

body :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Maybe HTMLElement)
body = map toMaybe <<< _body

foreign import _readyState :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) String

readyState :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) ReadyState
readyState = map (unsafePartial fromJust <<< parseReadyState) <<< _readyState

foreign import _activeElement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Nullable HTMLElement)

activeElement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Maybe HTMLElement)
activeElement = map toMaybe <<< _activeElement

module DOM.HTML.Document
  ( body
  , readyState
  , module Exports
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML.Document.ReadyState (ReadyState(..)) as Exports
import DOM.HTML.Document.ReadyState (ReadyState, parseReadyState)
import DOM.HTML.Types (HTMLElement, HTMLDocument)
import Data.Maybe (Maybe, fromJust)
import Data.Nullable (Nullable, toMaybe)
import Partial.Unsafe (unsafePartial)

foreign import _body :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Nullable HTMLElement)

body :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Maybe HTMLElement)
body = map toMaybe <<< _body

foreign import _readyState :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) String

readyState :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) ReadyState
readyState = map (unsafePartial fromJust <<< parseReadyState) <<< _readyState

foreign import _activeElement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Nullable HTMLElement)

activeElement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) (Maybe HTMLElement)
activeElement = map toMaybe <<< _activeElement


Add FIXME

Add FIXME

module PureSwift.CodeGen
 ( moduleToSwift
 ) where

import Prelude

import CoreFn.Expr (Bind(..), Expr(Abs, Accessor, App, Case, Constructor, ObjectUpdate, Let, Var))
import CoreFn.Expr (Expr(Literal)) as CoreFn
import CoreFn.Ident (Ident(..)) as CoreFn
import CoreFn.Literal (Literal(..)) as CoreFn
import CoreFn.Module (Module(..))
import CoreFn.Names (ModuleName(..), Qualified(..))
import Data.Array (concat, intercalate)
import Data.Bitraversable (bitraverse)
import Data.Char (toCharCode)
import Data.Char.Unicode (isAlphaNum)
import Data.Either (Either(..), either)
import Data.Foldable (elem, foldMap, foldr)
import Data.Int (decimal, toStringAs)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.String (singleton, toCharArray)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), Statement(..), Type(..))

moduleToSwift :: forall a. Module a -> Either String Decl
moduleToSwift (Module mod) = TopLevel <$> statements
  where
  decls :: Either String (List Decl)
  decls = foldr (append <<< declToSwift) (Right Nil) (List.fromFoldable mod.moduleDecls)

  extension :: Either String Decl
  extension = Extension (AccessModifier Public : Nil) (moduleNameToSwift mod.moduleName) <$> decls

  statements :: Either String (List Statement)
  statements = do
    extension' <- extension
    pure ( Declaration extension' : Nil )

  moduleNameToSwift :: ModuleName -> Ident
  moduleNameToSwift (ModuleName mn) = Ident $ intercalate "." (unwrap <$> mn)

  declToSwift :: Bind a -> Either String (List Decl)
  declToSwift (NonRec a i e) = do
    decl <- bindingToSwift (Tuple (Tuple a i) e)
    pure $ List.singleton decl
  declToSwift (Rec bs) = traverse bindingToSwift $ List.fromFoldable bs

  removeAttributes :: FunctionTypeArg -> FunctionTypeArg
  removeAttributes (FunctionTypeArg e i _ t) = FunctionTypeArg e i Nil t

  removeBothArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeBothArgLabels (FunctionTypeArg _ _ as t) = FunctionTypeArg Nothing Nothing as t

  removeAllReturnTypeArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeAllReturnTypeArgLabels (FunctionTypeArg as e i r) = FunctionTypeArg as e i (removeAllArgLabels r)

  removeAllArgLabels :: Type -> Type
  removeAllArgLabels = case _ of
    (FunctionType as t) ->
      FunctionType (removeBothArgLabels <<< removeAllReturnTypeArgLabels <$> as) (removeAllArgLabels t)
    typ -> typ

  expToType' :: (Type -> Type) -> Exp -> Maybe Type
  expToType' f = case _ of
    (Closure as r _) -> Just $ f $ FunctionType as r
    (Literal l) -> litToType l
    _ -> Nothing

  expToType :: Exp -> Maybe Type
  expToType = expToType' id

  litToType :: Lit -> Maybe Type
  litToType = case _ of
    IntLit _ -> Just IntType
    FloatLit _ -> Just FloatType
    CharLit _ -> Just CharType
    StringLit _ -> Just StringType
    BooleanLit _ -> Just BoolType
    _ -> Nothing

  bindingToSwift :: Tuple (Tuple a CoreFn.Ident) (CoreFn.Expr a) -> Either String Decl
  bindingToSwift (Tuple (Tuple _ ident) expr) = do
    ident' <- identToSwift ident
    exp <- exprToSwift expr
    pure $ Constant (accessMod : Static : Nil) ident' (expToType' removeAllArgLabels exp) exp
    where
    accessMod :: DeclMod
    accessMod = AccessModifier $ if isExported ident then Public else Internal

    isExported :: CoreFn.Ident -> Boolean
    isExported i = elem i mod.moduleExports

  identToSwift :: CoreFn.Ident -> Either String Ident
  identToSwift (CoreFn.Ident ident) = Right $ Ident $ properToSwift ident
  identToSwift (CoreFn.GenIdent _ _) = Left "GenIdent in identToSwift"
  identToSwift CoreFn.UnusedIdent = Right $ Ident "$__unused"

  properToSwift :: String -> String
  properToSwift name
    | nameIsSwiftReserved name = "`" <> name <> "`"
    | otherwise = foldMap identCharToString $ toCharArray name

  -- | Attempts to find a human-readable name for a symbol, if none has been
  -- | specified returns the ordinal value.
  identCharToString :: Char -> String
  identCharToString c | isAlphaNum c = singleton c
  identCharToString '_' = "_"
  identCharToString '.' = "$dot"
  identCharToString '$' = "$dollar"
  identCharToString '~' = "$tilde"
  identCharToString '=' = "$eq"
  identCharToString '<' = "$less"
  identCharToString '>' = "$greater"
  identCharToString '!' = "$bang"
  identCharToString '#' = "$hash"
  identCharToString '%' = "$percent"
  identCharToString '^' = "$up"
  identCharToString '&' = "$amp"
  identCharToString '|' = "$bar"
  identCharToString '*' = "$times"
  identCharToString '/' = "$div"
  identCharToString '+' = "$plus"
  identCharToString '-' = "$minus"
  identCharToString ':' = "$colon"
  identCharToString '\\' = "$bslash"
  identCharToString '?' = "$qmark"
  identCharToString '@' = "$at"
  identCharToString '\'' = "$prime"
  identCharToString c = "$" <> (toStringAs decimal $ toCharCode c)

  -- | Checks whether an identifier name is reserved in Swift.
  nameIsSwiftReserved :: String -> Boolean
  nameIsSwiftReserved name = name `elem` swiftAnyReserved

  swiftAnyReserved :: Array String
  swiftAnyReserved =
    concat
      [ swiftDeclKeywords
      , swiftStatementKeywords
      , swiftExprTypeKeywords
      , swiftPatternKeywords
      , swiftNumberSignKeywords
      , swiftContextualKeywords
      ]

  swiftDeclKeywords :: Array String
  swiftDeclKeywords =
    [ "associatedtype"
    , "class"
    , "deinit"
    , "enum"
    , "extension"
    , "fileprivate"
    , "func"
    , "import"
    , "init"
    , "inout"
    , "internal"
    , "let"
    , "open"
    , "operator"
    , "private"
    , "protocol"
    , "public"
    , "static"
    , "struct"
    , "subscript"
    , "typealias"
    , "var"
    ]

  swiftStatementKeywords :: Array String
  swiftStatementKeywords =
    [ "break"
    , "case"
    , "continue"
    , "default"
    , "defer"
    , "do"
    , "else"
    , "fallthrough"
    , "for"
    , "guard"
    , "if"
    , "in"
    , "repeat"
    , "return"
    , "switch"
    , "where"
    , "while"
    ]

  swiftExprTypeKeywords :: Array String
  swiftExprTypeKeywords =
    [ "as"
    , "Any"
    , "catch"
    , "false"
    , "is"
    , "nil"
    , "rethrows"
    , "super"
    , "self"
    , "Self"
    , "throw"
    , "throws"
    , "true"
    , "try"
    ]

  swiftPatternKeywords :: Array String
  swiftPatternKeywords =
    [ "_"
    ]

  swiftNumberSignKeywords :: Array String
  swiftNumberSignKeywords =
    [ "#available"
    , "#colorLiteral"
    , "#column"
    , "#else"
    , "#elseif"
    , "#endif"
    , "#file"
    , "#fileLiteral"
    , "#function"
    , "#if"
    , "#imageLiteral"
    , "#line"
    , "#selector"
    , "#sourceLocation"
    ]

  swiftContextualKeywords :: Array String
  swiftContextualKeywords =
    [ "associativity"
    , "convenience"
    , "dynamic"
    , "didSet"
    , "final"
    , "get"
    , "infix"
    , "indirect"
    , "lazy"
    , "left"
    , "mutating"
    , "none"
    , "nonmutating"
    , "optional"
    , "override"
    , "postfix"
    , "precedence"
    , "prefix"
    , "Protocol"
    , "required"
    , "right"
    , "set"
    , "Type"
    , "unowned"
    , "weak"
    , "willSet"
    ]

  exprToSwift :: CoreFn.Expr a -> Either String Exp
  exprToSwift (CoreFn.Literal _ l) = Literal <$> literalToSwift l
  exprToSwift (Constructor _ tn cn fs) = Right $ Literal $ StringLit "/* FIXME: Constructor Exp */"
  exprToSwift (Accessor _ s e) = Right $ Literal $ StringLit "/* FIXME: Accessor Exp */"
  exprToSwift (ObjectUpdate _ e ts) = Right $ Literal $ StringLit "/* FIXME: ObjectUpdate Exp */"
  exprToSwift (Abs _ i e) = Closure <$> args <*> returnType <*> ss
    where
    exp :: Either String Exp
    exp = exprToSwift e

    atts :: Either String (List Attribute)
    atts = do
      exp' <- exp
      pure $ case exp' of
        Closure _ _ _ -> Escaping : Nil
        _ -> Nil

    returnType :: Either String Type
    returnType = do
      exp' <- exp
      pure $ fromMaybe AnyType $ expToType exp' -- FIXME: return type for functions

    args :: Either String (List FunctionTypeArg)
    args = do
      ident <- identToSwift i
      atts' <- atts
      returnType' <- returnType
      pure $
        ( FunctionTypeArg (Just $ Ident "_") (Just ident) atts' returnType'
        : Nil
        )

    ss :: Either String (List Statement)
    ss = do
      exp' <- exp
      pure $
        ( Return (Just exp')
        : Nil
        )
  exprToSwift (App _ e1 e2) = do
    exp1 <- exprToSwift e1
    exp2 <- exprToSwift e2
    pure $ FunctionCall exp1 (exp2 : Nil)
  exprToSwift (Var _ q) = qualifiedToSwift q
  exprToSwift (Case _ es cs) = Right $ Literal $ StringLit "/* FIXME: Case Exp */"
  exprToSwift (Let _ bs e) = Right $ Literal $ StringLit "/* FIXME: Let Exp */"

  literalToSwift :: CoreFn.Literal (Expr a) -> Either String Lit
  literalToSwift (CoreFn.NumericLiteral x) = Right $ either IntLit FloatLit x
  literalToSwift (CoreFn.StringLiteral x) = Right $ StringLit x
  literalToSwift (CoreFn.CharLiteral x) = Right $ CharLit x
  literalToSwift (CoreFn.BooleanLiteral x) = Right $ BooleanLit x
  literalToSwift (CoreFn.ArrayLiteral xs) = ArrayLit <$> traverse exprToSwift (List.fromFoldable xs)
  literalToSwift (CoreFn.ObjectLiteral xs) = DictLit <<< Map.fromFoldable <$> xs'
    where
    bitraverseTuple :: Tuple String (CoreFn.Expr a) -> Either String (Tuple Exp Exp)
    bitraverseTuple = bitraverse (Right <<< Literal <<< StringLit) exprToSwift

    xs' :: Either String (Array (Tuple Exp Exp))
    xs' = traverse bitraverseTuple xs

  qualifiedToSwift :: Qualified CoreFn.Ident -> Either String Exp
  qualifiedToSwift (Qualified q i) =
    case q of
      Just m -> ExplicitMember (Identifier $ moduleNameToSwift m) <$> ident
      Nothing -> Identifier <$> ident
    where
      ident = identToSwift i

module PureSwift.CodeGen
 ( moduleToSwift
 ) where

import Prelude

import CoreFn.Expr (Bind(..), Expr(Abs, Accessor, App, Case, Constructor, ObjectUpdate, Let, Var))
import CoreFn.Expr (Expr(Literal)) as CoreFn
import CoreFn.Ident (Ident(..)) as CoreFn
import CoreFn.Literal (Literal(..)) as CoreFn
import CoreFn.Module (Module(..))
import CoreFn.Names (ModuleName(..), Qualified(..))
import Data.Array (concat, intercalate)
import Data.Bitraversable (bitraverse)
import Data.Char (toCharCode)
import Data.Char.Unicode (isAlphaNum)
import Data.Either (Either(..), either)
import Data.Foldable (elem, foldMap, foldr)
import Data.Int (decimal, toStringAs)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.String (singleton, toCharArray)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), Statement(..), Type(..))

moduleToSwift :: forall a. Module a -> Either String Decl
moduleToSwift (Module mod) = TopLevel <$> statements
  where
  decls :: Either String (List Decl)
  decls = foldr (append <<< declToSwift) (Right Nil) (List.fromFoldable mod.moduleDecls)

  extension :: Either String Decl
  extension = Extension (AccessModifier Public : Nil) (moduleNameToSwift mod.moduleName) <$> decls

  statements :: Either String (List Statement)
  statements = do
    extension' <- extension
    pure ( Declaration extension' : Nil )

  moduleNameToSwift :: ModuleName -> Ident
  moduleNameToSwift (ModuleName mn) = Ident $ intercalate "." (unwrap <$> mn)

  declToSwift :: Bind a -> Either String (List Decl)
  declToSwift (NonRec a i e) = do
    decl <- bindingToSwift (Tuple (Tuple a i) e)
    pure $ List.singleton decl
  declToSwift (Rec bs) = traverse bindingToSwift $ List.fromFoldable bs

  removeAttributes :: FunctionTypeArg -> FunctionTypeArg
  removeAttributes (FunctionTypeArg e i _ t) = FunctionTypeArg e i Nil t

  removeBothArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeBothArgLabels (FunctionTypeArg _ _ as t) = FunctionTypeArg Nothing Nothing as t

  removeAllReturnTypeArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeAllReturnTypeArgLabels (FunctionTypeArg as e i r) = FunctionTypeArg as e i (removeAllArgLabels r)

  removeAllArgLabels :: Type -> Type
  removeAllArgLabels = case _ of
    (FunctionType as t) ->
      FunctionType (removeBothArgLabels <<< removeAllReturnTypeArgLabels <$> as) (removeAllArgLabels t)
    typ -> typ

  expToType' :: (Type -> Type) -> Exp -> Maybe Type
  expToType' f = case _ of
    (Closure as r _) -> Just $ f $ FunctionType as r
    (Literal l) -> litToType l
    _ -> Nothing

  expToType :: Exp -> Maybe Type
  expToType = expToType' id

  litToType :: Lit -> Maybe Type
  litToType = case _ of
    IntLit _ -> Just IntType
    FloatLit _ -> Just FloatType
    CharLit _ -> Just CharType
    StringLit _ -> Just StringType
    BooleanLit _ -> Just BoolType
    _ -> Nothing

  bindingToSwift :: Tuple (Tuple a CoreFn.Ident) (CoreFn.Expr a) -> Either String Decl
  bindingToSwift (Tuple (Tuple _ ident) expr) = do
    ident' <- identToSwift ident
    exp <- exprToSwift expr
    pure $ Constant (accessMod : Static : Nil) ident' (expToType' removeAllArgLabels exp) exp
    where
    accessMod :: DeclMod
    accessMod = AccessModifier $ if isExported ident then Public else Internal

    isExported :: CoreFn.Ident -> Boolean
    isExported i = elem i mod.moduleExports

  identToSwift :: CoreFn.Ident -> Either String Ident
  identToSwift (CoreFn.Ident ident) = Right $ Ident $ properToSwift ident
  identToSwift (CoreFn.GenIdent _ _) = Left "GenIdent in identToSwift"
  identToSwift CoreFn.UnusedIdent = Right $ Ident "$__unused"

  properToSwift :: String -> String
  properToSwift name
    | nameIsSwiftReserved name = "`" <> name <> "`"
    | otherwise = foldMap identCharToString $ toCharArray name

  -- | Attempts to find a human-readable name for a symbol, if none has been
  -- | specified returns the ordinal value.
  identCharToString :: Char -> String
  identCharToString c | isAlphaNum c = singleton c
  identCharToString '_' = "_"
  identCharToString '.' = "$dot"
  identCharToString '$' = "$dollar"
  identCharToString '~' = "$tilde"
  identCharToString '=' = "$eq"
  identCharToString '<' = "$less"
  identCharToString '>' = "$greater"
  identCharToString '!' = "$bang"
  identCharToString '#' = "$hash"
  identCharToString '%' = "$percent"
  identCharToString '^' = "$up"
  identCharToString '&' = "$amp"
  identCharToString '|' = "$bar"
  identCharToString '*' = "$times"
  identCharToString '/' = "$div"
  identCharToString '+' = "$plus"
  identCharToString '-' = "$minus"
  identCharToString ':' = "$colon"
  identCharToString '\\' = "$bslash"
  identCharToString '?' = "$qmark"
  identCharToString '@' = "$at"
  identCharToString '\'' = "$prime"
  identCharToString c = "$" <> (toStringAs decimal $ toCharCode c)

  -- | Checks whether an identifier name is reserved in Swift.
  nameIsSwiftReserved :: String -> Boolean
  nameIsSwiftReserved name = name `elem` swiftAnyReserved

  swiftAnyReserved :: Array String
  swiftAnyReserved =
    concat
      [ swiftDeclKeywords
      , swiftStatementKeywords
      , swiftExprTypeKeywords
      , swiftPatternKeywords
      , swiftNumberSignKeywords
      , swiftContextualKeywords
      ]

  swiftDeclKeywords :: Array String
  swiftDeclKeywords =
    [ "associatedtype"
    , "class"
    , "deinit"
    , "enum"
    , "extension"
    , "fileprivate"
    , "func"
    , "import"
    , "init"
    , "inout"
    , "internal"
    , "let"
    , "open"
    , "operator"
    , "private"
    , "protocol"
    , "public"
    , "static"
    , "struct"
    , "subscript"
    , "typealias"
    , "var"
    ]

  swiftStatementKeywords :: Array String
  swiftStatementKeywords =
    [ "break"
    , "case"
    , "continue"
    , "default"
    , "defer"
    , "do"
    , "else"
    , "fallthrough"
    , "for"
    , "guard"
    , "if"
    , "in"
    , "repeat"
    , "return"
    , "switch"
    , "where"
    , "while"
    ]

  swiftExprTypeKeywords :: Array String
  swiftExprTypeKeywords =
    [ "as"
    , "Any"
    , "catch"
    , "false"
    , "is"
    , "nil"
    , "rethrows"
    , "super"
    , "self"
    , "Self"
    , "throw"
    , "throws"
    , "true"
    , "try"
    ]

  swiftPatternKeywords :: Array String
  swiftPatternKeywords =
    [ "_"
    ]

  swiftNumberSignKeywords :: Array String
  swiftNumberSignKeywords =
    [ "#available"
    , "#colorLiteral"
    , "#column"
    , "#else"
    , "#elseif"
    , "#endif"
    , "#file"
    , "#fileLiteral"
    , "#function"
    , "#if"
    , "#imageLiteral"
    , "#line"
    , "#selector"
    , "#sourceLocation"
    ]

  swiftContextualKeywords :: Array String
  swiftContextualKeywords =
    [ "associativity"
    , "convenience"
    , "dynamic"
    , "didSet"
    , "final"
    , "get"
    , "infix"
    , "indirect"
    , "lazy"
    , "left"
    , "mutating"
    , "none"
    , "nonmutating"
    , "optional"
    , "override"
    , "postfix"
    , "precedence"
    , "prefix"
    , "Protocol"
    , "required"
    , "right"
    , "set"
    , "Type"
    , "unowned"
    , "weak"
    , "willSet"
    ]

  exprToSwift :: CoreFn.Expr a -> Either String Exp
  exprToSwift (CoreFn.Literal _ l) = Literal <$> literalToSwift l
  exprToSwift (Constructor _ tn cn fs) = Right $ Literal $ StringLit "/* FIXME: Constructor Exp */"
  exprToSwift (Accessor _ s e) = Right $ Literal $ StringLit "/* FIXME: Accessor Exp */"
  exprToSwift (ObjectUpdate _ e ts) = Right $ Literal $ StringLit "/* FIXME: ObjectUpdate Exp */"
  exprToSwift (Abs _ i e) = Closure <$> args <*> returnType <*> ss
    where
    exp :: Either String Exp
    exp = exprToSwift e

    atts :: Either String (List Attribute)
    atts = do
      exp' <- exp
      pure $ case exp' of
        Closure _ _ _ -> Escaping : Nil
        _ -> Nil

    returnType :: Either String Type
    returnType = do
      exp' <- exp
      pure $ fromMaybe AnyType $ expToType exp'

    args :: Either String (List FunctionTypeArg)
    args = do
      ident <- identToSwift i
      atts' <- atts
      returnType' <- returnType
      pure $
        ( FunctionTypeArg (Just $ Ident "_") (Just ident) atts' returnType'
        : Nil
        )

    ss :: Either String (List Statement)
    ss = do
      exp' <- exp
      pure $
        ( Return (Just exp')
        : Nil
        )
  exprToSwift (App _ e1 e2) = do
    exp1 <- exprToSwift e1
    exp2 <- exprToSwift e2
    pure $ FunctionCall exp1 (exp2 : Nil)
  exprToSwift (Var _ q) = qualifiedToSwift q
  exprToSwift (Case _ es cs) = Right $ Literal $ StringLit "/* FIXME: Case Exp */"
  exprToSwift (Let _ bs e) = Right $ Literal $ StringLit "/* FIXME: Let Exp */"

  literalToSwift :: CoreFn.Literal (Expr a) -> Either String Lit
  literalToSwift (CoreFn.NumericLiteral x) = Right $ either IntLit FloatLit x
  literalToSwift (CoreFn.StringLiteral x) = Right $ StringLit x
  literalToSwift (CoreFn.CharLiteral x) = Right $ CharLit x
  literalToSwift (CoreFn.BooleanLiteral x) = Right $ BooleanLit x
  literalToSwift (CoreFn.ArrayLiteral xs) = ArrayLit <$> traverse exprToSwift (List.fromFoldable xs)
  literalToSwift (CoreFn.ObjectLiteral xs) = DictLit <<< Map.fromFoldable <$> xs'
    where
    bitraverseTuple :: Tuple String (CoreFn.Expr a) -> Either String (Tuple Exp Exp)
    bitraverseTuple = bitraverse (Right <<< Literal <<< StringLit) exprToSwift

    xs' :: Either String (Array (Tuple Exp Exp))
    xs' = traverse bitraverseTuple xs

  qualifiedToSwift :: Qualified CoreFn.Ident -> Either String Exp
  qualifiedToSwift (Qualified q i) =
    case q of
      Just m -> ExplicitMember (Identifier $ moduleNameToSwift m) <$> ident
      Nothing -> Identifier <$> ident
    where
      ident = identToSwift i


Remove MonadEff from MonadTrans

Remove MonadEff from MonadTrans

module Control.Monad.Trans where

import Prelude

class MonadTrans t where
  lift :: forall m a. (Monad m) => m a -> t m a

module Control.Monad.Trans where

import Prelude
import Control.Monad.Eff

class MonadTrans t where
  lift :: forall m a. (Monad m) => m a -> t m a

class MonadEff m where
  liftEff :: forall eff a. Eff eff a -> m a