reveals flaw in design

reveals flaw in design

unless the monad contains a function we don’t get any means to get at the contents of the monad in the instance functions for the AbstractSelection? right?
so next step is to bring back the Monad (structure -> Tuple a structure) as in Phil’s example and the FakeSelection. But at the same time preserving the typed nature of the D3 Selection

module TaglessD3.DOMImpl where

import D3.Base (D3Selection) as D3
import D3.Selection (Selection, d3Select) as D3
import Data.Maybe (Maybe(..))
import Data.Profunctor.Strong (first)
import Data.Tuple (Tuple(..), fst, snd)
import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, class Show, Unit, ap, show, unit, ($), (<<<), (<>), (<$>))
import TaglessD3.Base (Attr, D3ElementType, D3Transition, Hierarchy, Selector, renderArrayOfAttributes)
import TaglessD3.Selection (class AbstractSelection)

data D3Data = AI (Array Int)
            | AN (Array Number)
            | AS (Array String)
            | AC (Array Char)
            | HI (Hierarchy Int)
            | HN (Hierarchy Number)
            | HS (Hierarchy String)
            | HC (Hierarchy Char)

-- | a very simple Monad to hold the Selection and the data that is bound to it
data D3Monad d a = D3Monad (Maybe (D3.Selection d)) (Maybe D3Data) a

instance functorD3Monad :: Functor (D3Monad d) where
    map f (D3Monad s d x) = D3Monad s d (f x)

instance applyD3Monad :: Apply (D3Monad d) where
    apply (D3Monad s d fn) x = fn <$> x

instance applicativeD3Monad :: Applicative (D3Monad d) where
    pure d = D3Monad Nothing Nothing d

instance bindD3Monad :: Bind (D3Monad d) where
    bind d3m@(D3Monad s d x) k = concat d3m $ k x
        where
        concat :: ∀  s d s' d'. D3Monad s d -> D3Monad s' d' -> D3Monad s d'
        concat (D3Monad s d x) (D3Monad s' d' y) = (D3Monad s d y)

instance monadD3Monad :: Monad (D3Monad d)

instance selectionDummySelection :: AbstractSelection (D3Monad d) where
    d3Select selector    = D3Monad (d3Select'    selector) Nothing unit
    d3SelectAll selector = D3Monad (d3SelectAll' selector) Nothing unit
    select selector      = D3Monad (select'      selector) Nothing unit
    selectAll selector   = D3Monad (selectAll'   selector) Nothing unit
    merge selection      = D3Monad
    insert element       = D3Monad
    append element       = D3Monad
    remove               = D3Monad
    enter                = D3Monad
    exit                 = D3Monad
    attrs attributes     = D3Monad
    transition t         = D3Monad
    dataA ds             = D3Monad
    dataH hd             = D3Monad
    dataAI ds index      = D3Monad
    dataHI hd index      = D3Monad

d3Select' :: ∀ d. Selector -> Maybe (D3.Selection d)
d3Select' _ = Nothing

-- d3Select' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- d3Select' selector d3s = Tuple unit (D3S (d3Select selector))
--
-- d3SelectAll' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- d3SelectAll' selector d3s = Tuple unit d3s
--
-- select' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- select' selector d3s = Tuple unit d3s
--
-- selectAll' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- selectAll' selector d3s = Tuple unit d3s
--
-- insert' :: ∀ d. D3ElementType -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- insert' element d3s = Tuple unit d3s
--
-- append' :: ∀ d. D3ElementType -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- append' element d3s = Tuple unit d3s
--
-- remove' :: ∀ d. D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- remove' d3s = Tuple unit d3s
--
-- enter' :: ∀ d. D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- enter' d3s = Tuple unit d3s
--
-- exit' :: ∀ d. D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- exit' d3s = Tuple unit d3s
--
-- attrs' :: ∀ d. Array (Attr d) -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- attrs' as d3s = Tuple unit d3s
--
-- transition' :: ∀ d. D3Transition -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- transition' t d3s = Tuple unit d3s
--
-- dataA' :: ∀ d. Array d -> D3DOMStructure d -> Tuple (Array d) (D3DOMStructure d)
-- dataA' ds d3s = Tuple ds d3s
--
-- dataH' :: ∀ d. Hierarchy d -> D3DOMStructure d -> Tuple (Hierarchy d) (D3DOMStructure d)
-- dataH' hd d3s = Tuple hd d3s
--
-- dataAI' :: ∀ d i. Array d -> (d -> i) -> D3DOMStructure d -> Tuple (Array d) (D3DOMStructure d)
-- dataAI' ds index d3s = Tuple ds d3s
--
-- dataHI' :: ∀ d i. Hierarchy d -> (d -> i) -> D3DOMStructure d -> Tuple (Hierarchy d) (D3DOMStructure d)
-- dataHI' hd index d3s = Tuple hd d3s
--
-- merge' :: ∀ d. D3Wrapper Unit -> D3DOMStructure d -> (Tuple Unit (D3DOMStructure d))
-- merge' (D3Wrapper f) (D3S name selection) = Tuple unit (D3S name selection)
--

module TaglessD3.DOMImpl where

import D3.Base (D3Selection) as D3
import D3.Selection (Selection, d3Select) as D3
import Data.Maybe (Maybe(..))
import Data.Profunctor.Strong (first)
import Data.Tuple (Tuple(..), fst, snd)
import Prelude (class Applicative, class Apply, class Bind, class Functor, class Monad, class Show, Unit, ap, show, unit, ($), (<<<), (<>), (<$>))
import TaglessD3.Base (Attr, D3ElementType, D3Transition, Hierarchy, Selector, renderArrayOfAttributes)
import TaglessD3.Selection (class AbstractSelection)

data D3Data = AI (Array Int)
            | AN (Array Number)
            | AS (Array String)
            | AC (Array Char)
            | HI (Hierarchy Int)
            | HN (Hierarchy Number)
            | HS (Hierarchy String)
            | HC (Hierarchy Char)

-- | a very simple Monad to hold the Selection and the data that is bound to it
data D3Monad d a = D3Monad (Maybe (D3.Selection d)) (Maybe D3Data) a

instance functorD3Monad :: Functor (D3Monad d) where
    map f (D3Monad s d x) = D3Monad s d (f x)

instance applyD3Monad :: Apply (D3Monad d) where
    apply (D3Monad s d fn) x = fn <$> x

instance applicativeD3Monad :: Applicative (D3Monad d) where
    pure d = D3Monad Nothing Nothing d

instance bindD3Monad :: Bind (D3Monad d) where
    bind d3m@(D3Monad s d x) k = concat d3m $ k x

concat :: ∀  s d s' d'. D3Monad s d -> D3Monad s' d' -> D3Monad s d'
concat (D3Monad s d x) (D3Monad s' d' y) = (D3Monad s d y)

instance monadD3Monad :: Monad (D3Monad d)

-- instance selectionDummySelection :: AbstractSelection D3Monad where
--     d3Select selector    = Selection
--     d3SelectAll selector = Selection
--     select selector      = Selection
--     selectAll selector   = Selection
--     merge selection      = Selection
--     insert element       = Selection
--     append element       = Selection
--     remove               = Selection
--     enter                = Selection
--     exit                 = Selection
--     attrs attributes     = Selection
--     transition t         = Selection
--     dataA ds             = Selection
--     dataH hd             = Selection
--     dataAI ds index      = Selection
--     dataHI hd index      = Selection
--
-- d3Select' :: ∀ d. Selector ->
--
-- d3Select' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- d3Select' selector d3s = Tuple unit (D3S (d3Select selector))
--
-- d3SelectAll' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- d3SelectAll' selector d3s = Tuple unit d3s
--
-- select' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- select' selector d3s = Tuple unit d3s
--
-- selectAll' :: ∀ d. Selector -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- selectAll' selector d3s = Tuple unit d3s
--
-- insert' :: ∀ d. D3ElementType -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- insert' element d3s = Tuple unit d3s
--
-- append' :: ∀ d. D3ElementType -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- append' element d3s = Tuple unit d3s
--
-- remove' :: ∀ d. D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- remove' d3s = Tuple unit d3s
--
-- enter' :: ∀ d. D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- enter' d3s = Tuple unit d3s
--
-- exit' :: ∀ d. D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- exit' d3s = Tuple unit d3s
--
-- attrs' :: ∀ d. Array (Attr d) -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- attrs' as d3s = Tuple unit d3s
--
-- transition' :: ∀ d. D3Transition -> D3DOMStructure d -> Tuple Unit (D3DOMStructure d)
-- transition' t d3s = Tuple unit d3s
--
-- dataA' :: ∀ d. Array d -> D3DOMStructure d -> Tuple (Array d) (D3DOMStructure d)
-- dataA' ds d3s = Tuple ds d3s
--
-- dataH' :: ∀ d. Hierarchy d -> D3DOMStructure d -> Tuple (Hierarchy d) (D3DOMStructure d)
-- dataH' hd d3s = Tuple hd d3s
--
-- dataAI' :: ∀ d i. Array d -> (d -> i) -> D3DOMStructure d -> Tuple (Array d) (D3DOMStructure d)
-- dataAI' ds index d3s = Tuple ds d3s
--
-- dataHI' :: ∀ d i. Hierarchy d -> (d -> i) -> D3DOMStructure d -> Tuple (Hierarchy d) (D3DOMStructure d)
-- dataHI' hd index d3s = Tuple hd d3s
--
-- merge' :: ∀ d. D3Wrapper Unit -> D3DOMStructure d -> (Tuple Unit (D3DOMStructure d))
-- merge' (D3Wrapper f) (D3S name selection) = Tuple unit (D3S name selection)
--


update pursuit docs (#19)

update pursuit docs (#19)

module Run
  ( Run(..)
  , lift
  , send
  , extract
  , interpret
  , interpretRec
  , run
  , runRec
  , runCont
  , runPure
  , runAccum
  , runAccumRec
  , runAccumCont
  , runAccumPure
  , peel
  , resume
  , expand
  , EFFECT
  , AFF
  , liftEffect
  , liftAff
  , runBaseEffect
  , runBaseAff
  , runBaseAff'
  , module Data.Functor.Variant
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Effect (Effect)
import Effect.Class (class MonadEffect)
import Effect.Class as Effect
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Control.Monad.Free (Free, liftF, runFree, runFreeM, resume')
import Control.Monad.Rec.Class (Step(..)) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Plus (class Plus)
import Data.Either (Either(..))
import Data.Functor.Variant (FProxy(..), VariantF, case_, default, inj, match, on, onMatch)
import Data.Newtype (class Newtype, unwrap)
import Data.Symbol (SProxy(..)) as Exports
import Data.Symbol (SProxy(..), class IsSymbol)
import Data.Tuple (Tuple(..), curry, uncurry)
import Partial.Unsafe (unsafeCrashWith)
import Run.Internal (_choose, CHOOSE, Choose(..), toRows, fromRows)
import Type.Equality (class TypeEquals)
import Prim.Row as Row
import Type.Row (RProxy)
import Unsafe.Coerce (unsafeCoerce)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , effect ∷ EFFECT
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEffect $ log "Yes"
-- |     modify (_ - 1)
-- |   where
-- |   whileM_
-- |     ∷ ∀ a
-- |     . Run MyEffects Boolean
-- |     → Run MyEffects a
-- |     → Run MyEffects Unit
-- |   whileM_ mb ma = flip tailRecM unit \a →
-- |     mb >>= if _ then ma $> Loop unit else pure $ Done unit
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEffect <<< log)
-- |     # runState 10
-- |     # runBaseEffect
-- |     # void
-- | ````
newtype Run r a = Run (Free (VariantF r) a)

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | This instance is provided for compatibility, but is otherwise
-- | unnecessary. You can use monadic recursion with `Run`, deferring the
-- | `MonadRec` constraint till it is interpretted.
instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `SProxy` slot.
lift
  ∷ ∀ sym r1 r2 f a
  . Row.Cons sym (FProxy f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ SProxy sym
  → f a
  → Run r2 a
lift p = Run <<< liftF <<< inj p

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (VariantF r (Run r a)) a
peel = resume Left Right

-- | Eliminator for the `Run` data type.
resume
  ∷ ∀ a b r
  . (VariantF r (Run r a) → b)
  → (a → b)
  → Run r a
  → b
resume k1 k2 = resume' (\x f → k1 (Run <<< f <$> x)) k2 <<< unwrap

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . VariantF r a
  → Run r a
send = Run <<< liftF

-- | Casts some set of effects to a wider set of effects via a left-biased
-- | union. For example, you could take a closed effect and unify it with
-- | a superset of effects because we know the additional effects never
-- | occur.
-- |
-- | ```purescript
-- | type LessRows = (foo :: FOO)
-- | type MoreRows = (foo :: FOO, bar :: BAR, baz :: BAZ)
-- |
-- | foo :: Run LessRows Unit
-- | foo = foo
-- |
-- | foo' :: Run MoreRows Unit
-- | foo' = expand foo
-- | ```
expand
  ∷ ∀ r1 r2 rx a
  . Row.Union r1 rx r2
  ⇒ Run r1 a
  → Run r2 a
expand = unsafeCoerce

-- | Extracts the value from a purely interpreted program.
extract ∷ ∀ a. Run () a → a
extract = unwrap >>> runFree \_ → unsafeCrashWith "Run: the impossible happened"

-- | Extracts the value from a program via some Monad `m`. This assumes
-- | stack safety under Monadic recursion.
interpret
  ∷ ∀ m a r
  . Monad m
  ⇒ (VariantF r ~> m)
  → Run r a
  → m a
interpret = run

-- | Identical to `interpret` but with a less restrictive type signature,
-- | letting you intercept the rest of the program.
run
  ∷ ∀ m a r
  . Monad m
  ⇒ (VariantF r (Run r a) → m (Run r a))
  → Run r a
  → m a
run k = loop
  where
  loop ∷ Run r a → m a
  loop = resume (\a → loop =<< k a) pure

-- | Extracts the value from a program via some MonadRec `m`, preserving
-- | stack safety.
interpretRec
  ∷ ∀ m a r
  . MonadRec m
  ⇒ (VariantF r ~> m)
  → Run r a
  → m a
interpretRec = runRec

-- | Identical to `interpretRec` but with a less restrictive type
-- | signature, letting you intercept the rest of the program.
runRec
  ∷ ∀ m a r
  . MonadRec m
  ⇒ (VariantF r (Run r a) → m (Run r a))
  → Run r a
  → m a
runRec k = runFreeM (coerceM k) <<< unwrap
  where
  -- Just so we can avoid the overhead of mapping the Run constructor
  coerceM ∷ (VariantF r (Run r a) -> m (Run r a)) -> VariantF r (Free (VariantF r) a) -> m (Free (VariantF r) a)
  coerceM = unsafeCoerce

-- | Extracts the value from a program via some `m` using continuation passing.
runCont
  ∷ ∀ m a b r
  . (VariantF r (m b) → m b)
  → (a → m b)
  → Run r a
  → m b
runCont k1 k2 = loop
  where
  loop ∷ Run r a → m b
  loop = resume (\b -> k1 (loop <$> b)) k2

-- | Extracts the value from a program via some Monad `m` with an internal
-- | accumulator. This assumes stack safety under Monadic recursion.
runAccum
  ∷ ∀ m r s a
  . Monad m
  ⇒ (s → VariantF r (Run r a) → m (Tuple s (Run r a)))
  → s
  → Run r a
  → m a
runAccum k = loop
  where
  loop ∷ s → Run r a → m a
  loop s = resume (\b → uncurry loop =<< k s b) pure

-- | Extracts the value from a program via some MonadRec `m` with an internal
-- | accumulator.
runAccumRec
  ∷ ∀ m r s a
  . MonadRec m
  ⇒ (s → VariantF r (Run r a) → m (Tuple s (Run r a)))
  → s
  → Run r a
  → m a
runAccumRec k = curry (tailRecM (uncurry loop))
  where
  loop ∷ s → Run r a → m (Step (Tuple s (Run r a)) a)
  loop s = resume (\b → Loop <$> k s b) (pure <<< Done)

-- | Extracts the value from a program via some `m` using continuation passing
-- | with an internal accumulator.
runAccumCont
  ∷ ∀ m r s a b
  . (s → VariantF r (s → m b) → m b)
  → (s → a → m b)
  → s
  → Run r a
  → m b
runAccumCont k1 k2 = loop
  where
  loop ∷ s → Run r a → m b
  loop s = resume (\b → k1 s (flip loop <$> b)) (k2 s)

-- | Eliminates effects purely. Uses `Step` from `Control.Monad.Rec.Class` to
-- | preserve stack safety under tail recursion.
runPure
  ∷ ∀ r1 r2 a
  . (VariantF r1 (Run r1 a) → Step (Run r1 a) (VariantF r2 (Run r1 a)))
  → Run r1 a
  → Run r2 a
runPure k = loop
  where
  loop ∷ Run r1 a → Run r2 a
  loop r = case peel r of
    Left a → case k a of
      Loop r' → loop r'
      Done a' → send a' >>= runPure k
    Right a →
      pure a

-- | Eliminates effects purely with an internal accumulator. Uses `Step` from
-- | `Control.Monad.Rec.Class` to preserve stack safety under tail recursion.
runAccumPure
  ∷ ∀ r1 r2 a b s
  . (s → VariantF r1 (Run r1 a) → Step (Tuple s (Run r1 a)) (VariantF r2 (Run r1 a)))
  → (s → a → b)
  → s
  → Run r1 a
  → Run r2 b
runAccumPure k1 k2 = loop
  where
  loop ∷ s → Run r1 a → Run r2 b
  loop s r = case peel r of
    Left a → case k1 s a of
      Loop (Tuple s' r') → loop s' r'
      Done a' → send a' >>= runAccumPure k1 k2 s
    Right a →
      pure (k2 s a)

-- | Type synonym for using `Effect` as an effect.
type EFFECT = FProxy Effect

-- Lift an `Effect` effect into the `Run` Monad via the `effect` label.
liftEffect ∷ ∀ r. Effect ~> Run (effect ∷ EFFECT | r)
liftEffect = lift (SProxy ∷ SProxy "effect")

-- | Runs a base `Effect` effect.
runBaseEffect ∷ Run (effect ∷ EFFECT) ~> Effect
runBaseEffect = runRec $ match { effect: \a → a }

-- | Type synonym for using `Aff` as an effect.
type AFF = FProxy Aff

-- | Lift an `Aff` effect into the `Run` Monad via the `aff` label.
liftAff ∷ ∀ r. Aff ~> Run (aff ∷ AFF | r)
liftAff = lift (SProxy ∷ SProxy "aff")

-- | Runs a base `Aff` effect.
runBaseAff ∷ Run (aff ∷ AFF) ~> Aff
runBaseAff = run $ match { aff: \a → a }

-- | Runs base `Aff` and `Effect` together as one effect.
runBaseAff' ∷ Run (aff ∷ AFF, effect ∷ EFFECT) ~> Aff
runBaseAff' = run $ match { aff: \a → a, effect: \a → Effect.liftEffect a }

instance runMonadEffect ∷ (TypeEquals (RProxy r1) (RProxy (effect ∷ EFFECT | r2))) ⇒ MonadEffect (Run r1) where
  liftEffect = fromRows <<< liftEffect

-- | This will insert an `EFFECT` effect because `MonadAff` entails `MonadEffect`.
-- | If you don't want this, use `Run.liftAff` rather than `Control.Monad.Aff.Class.liftAff`.
instance runMonadAff ∷ (TypeEquals (RProxy r1) (RProxy (aff ∷ AFF, effect ∷ EFFECT | r2))) ⇒ MonadAff (Run r1) where
  liftAff = fromRows <<< liftAff

liftChoose ∷ ∀ r a. Choose a → Run (choose ∷ CHOOSE | r) a
liftChoose = lift _choose

instance runAlt ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Alt (Run r1) where
  alt a b = fromRows $ liftChoose (Alt identity) >>= if _ then toRows a else toRows b

instance runPlus ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Plus (Run r1) where
  empty = fromRows $ liftChoose Empty

instance runAlternative ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Alternative (Run r1)

module Run
  ( Run(..)
  , lift
  , send
  , extract
  , interpret
  , interpretRec
  , run
  , runRec
  , runCont
  , runPure
  , runAccum
  , runAccumRec
  , runAccumCont
  , runAccumPure
  , peel
  , resume
  , expand
  , EFFECT
  , AFF
  , liftEffect
  , liftAff
  , runBaseEffect
  , runBaseAff
  , runBaseAff'
  , module Data.Functor.Variant
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Effect (Effect)
import Effect.Class (class MonadEffect)
import Effect.Class as Eff
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff)
import Control.Monad.Free (Free, liftF, runFree, runFreeM, resume')
import Control.Monad.Rec.Class (Step(..)) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Plus (class Plus)
import Data.Either (Either(..))
import Data.Functor.Variant (FProxy(..), VariantF, case_, default, inj, match, on, onMatch)
import Data.Newtype (class Newtype, unwrap)
import Data.Symbol (SProxy(..)) as Exports
import Data.Symbol (SProxy(..), class IsSymbol)
import Data.Tuple (Tuple(..), curry, uncurry)
import Partial.Unsafe (unsafeCrashWith)
import Run.Internal (_choose, CHOOSE, Choose(..), toRows, fromRows)
import Type.Equality (class TypeEquals)
import Prim.Row as Row
import Type.Row (RProxy)
import Unsafe.Coerce (unsafeCoerce)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , eff ∷ EFF (console ∷ CONSOLE)
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEff $ log "Yes"
-- |     modify (_ - 1)
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEff <<< log)
-- |     # runState 10
-- |     # runBaseEff
-- |     # void
-- | ````
newtype Run r a = Run (Free (VariantF r) a)

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | This instance is provided for compatibility, but is otherwise
-- | unnecessary. You can use monadic recursion with `Run`, deferring the
-- | `MonadRec` constraint till it is interpretted.
instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `SProxy` slot.
lift
  ∷ ∀ sym r1 r2 f a
  . Row.Cons sym (FProxy f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ SProxy sym
  → f a
  → Run r2 a
lift p = Run <<< liftF <<< inj p

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (VariantF r (Run r a)) a
peel = resume Left Right

-- | Eliminator for the `Run` data type.
resume
  ∷ ∀ a b r
  . (VariantF r (Run r a) → b)
  → (a → b)
  → Run r a
  → b
resume k1 k2 = resume' (\x f → k1 (Run <<< f <$> x)) k2 <<< unwrap

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . VariantF r a
  → Run r a
send = Run <<< liftF

-- | Casts some set of effects to a wider set of effects via a left-biased
-- | union. For example, you could take a closed effect and unify it with
-- | a superset of effects because we know the additional effects never
-- | occur.
-- |
-- | ```purescript
-- | type LessRows = (foo :: FOO)
-- | type MoreRows = (foo :: FOO, bar :: BAR, baz :: BAZ)
-- |
-- | foo :: Run LessRows Unit
-- | foo = foo
-- |
-- | foo' :: Run MoreRows Unit
-- | foo' = expand foo
-- | ```
expand
  ∷ ∀ r1 r2 rx a
  . Row.Union r1 rx r2
  ⇒ Run r1 a
  → Run r2 a
expand = unsafeCoerce

-- | Extracts the value from a purely interpreted program.
extract ∷ ∀ a. Run () a → a
extract = unwrap >>> runFree \_ → unsafeCrashWith "Run: the impossible happened"

-- | Extracts the value from a program via some Monad `m`. This assumes
-- | stack safety under Monadic recursion.
interpret
  ∷ ∀ m a r
  . Monad m
  ⇒ (VariantF r ~> m)
  → Run r a
  → m a
interpret = run

-- | Identical to `interpret` but with a less restrictive type signature,
-- | letting you intercept the rest of the program.
run
  ∷ ∀ m a r
  . Monad m
  ⇒ (VariantF r (Run r a) → m (Run r a))
  → Run r a
  → m a
run k = loop
  where
  loop ∷ Run r a → m a
  loop = resume (\a → loop =<< k a) pure

-- | Extracts the value from a program via some MonadRec `m`, preserving
-- | stack safety.
interpretRec
  ∷ ∀ m a r
  . MonadRec m
  ⇒ (VariantF r ~> m)
  → Run r a
  → m a
interpretRec = runRec

-- | Identical to `interpretRec` but with a less restrictive type
-- | signature, letting you intercept the rest of the program.
runRec
  ∷ ∀ m a r
  . MonadRec m
  ⇒ (VariantF r (Run r a) → m (Run r a))
  → Run r a
  → m a
runRec k = runFreeM (coerceM k) <<< unwrap
  where
  -- Just so we can avoid the overhead of mapping the Run constructor
  coerceM ∷ (VariantF r (Run r a) -> m (Run r a)) -> VariantF r (Free (VariantF r) a) -> m (Free (VariantF r) a)
  coerceM = unsafeCoerce

-- | Extracts the value from a program via some `m` using continuation passing.
runCont
  ∷ ∀ m a b r
  . (VariantF r (m b) → m b)
  → (a → m b)
  → Run r a
  → m b
runCont k1 k2 = loop
  where
  loop ∷ Run r a → m b
  loop = resume (\b -> k1 (loop <$> b)) k2

-- | Extracts the value from a program via some Monad `m` with an internal
-- | accumulator. This assumes stack safety under Monadic recursion.
runAccum
  ∷ ∀ m r s a
  . Monad m
  ⇒ (s → VariantF r (Run r a) → m (Tuple s (Run r a)))
  → s
  → Run r a
  → m a
runAccum k = loop
  where
  loop ∷ s → Run r a → m a
  loop s = resume (\b → uncurry loop =<< k s b) pure

-- | Extracts the value from a program via some MonadRec `m` with an internal
-- | accumulator.
runAccumRec
  ∷ ∀ m r s a
  . MonadRec m
  ⇒ (s → VariantF r (Run r a) → m (Tuple s (Run r a)))
  → s
  → Run r a
  → m a
runAccumRec k = curry (tailRecM (uncurry loop))
  where
  loop ∷ s → Run r a → m (Step (Tuple s (Run r a)) a)
  loop s = resume (\b → Loop <$> k s b) (pure <<< Done)

-- | Extracts the value from a program via some `m` using continuation passing
-- | with an internal accumulator.
runAccumCont
  ∷ ∀ m r s a b
  . (s → VariantF r (s → m b) → m b)
  → (s → a → m b)
  → s
  → Run r a
  → m b
runAccumCont k1 k2 = loop
  where
  loop ∷ s → Run r a → m b
  loop s = resume (\b → k1 s (flip loop <$> b)) (k2 s)

-- | Eliminates effects purely. Uses `Step` from `Control.Monad.Rec.Class` to
-- | preserve stack safety under tail recursion.
runPure
  ∷ ∀ r1 r2 a
  . (VariantF r1 (Run r1 a) → Step (Run r1 a) (VariantF r2 (Run r1 a)))
  → Run r1 a
  → Run r2 a
runPure k = loop
  where
  loop ∷ Run r1 a → Run r2 a
  loop r = case peel r of
    Left a → case k a of
      Loop r' → loop r'
      Done a' → send a' >>= runPure k
    Right a →
      pure a

-- | Eliminates effects purely with an internal accumulator. Uses `Step` from
-- | `Control.Monad.Rec.Class` to preserve stack safety under tail recursion.
runAccumPure
  ∷ ∀ r1 r2 a b s
  . (s → VariantF r1 (Run r1 a) → Step (Tuple s (Run r1 a)) (VariantF r2 (Run r1 a)))
  → (s → a → b)
  → s
  → Run r1 a
  → Run r2 b
runAccumPure k1 k2 = loop
  where
  loop ∷ s → Run r1 a → Run r2 b
  loop s r = case peel r of
    Left a → case k1 s a of
      Loop (Tuple s' r') → loop s' r'
      Done a' → send a' >>= runAccumPure k1 k2 s
    Right a →
      pure (k2 s a)

-- | Type synonym for using `Eff` as an effect.
type EFFECT = FProxy Effect

-- Lift an `Eff` effect into the `Run` Monad via the `eff` label.
liftEffect ∷ ∀ r. Effect ~> Run (effect ∷ EFFECT | r)
liftEffect = lift (SProxy ∷ SProxy "effect")

-- | Runs a base `Eff` effect.
runBaseEffect ∷ Run (effect ∷ EFFECT) ~> Effect
runBaseEffect = runRec $ match { effect: \a → a }

-- | Type synonym for using `Aff` as an effect.
type AFF = FProxy Aff

-- | Lift an `Aff` effect into the `Run` Monad via the `aff` label.
liftAff ∷ ∀ r. Aff ~> Run (aff ∷ AFF | r)
liftAff = lift (SProxy ∷ SProxy "aff")

-- | Runs a base `Aff` effect.
runBaseAff ∷ Run (aff ∷ AFF) ~> Aff
runBaseAff = run $ match { aff: \a → a }

-- | Runs base `Aff` and `Eff` together as one effect.
runBaseAff' ∷ Run (aff ∷ AFF, effect ∷ EFFECT) ~> Aff
runBaseAff' = run $ match { aff: \a → a, effect: \a → Eff.liftEffect a }

instance runMonadEff ∷ (TypeEquals (RProxy r1) (RProxy (effect ∷ EFFECT | r2))) ⇒ MonadEffect (Run r1) where
  liftEffect = fromRows <<< liftEffect

-- | This will insert an `EFF` effect because `MonadAff` entails `MonadEff`.
-- | If you don't want this, use `Run.liftAff` rather than `Control.Monad.Aff.Class.liftAff`.
instance runMonadAff ∷ (TypeEquals (RProxy r1) (RProxy (aff ∷ AFF, effect ∷ EFFECT | r2))) ⇒ MonadAff (Run r1) where
  liftAff = fromRows <<< liftAff

liftChoose ∷ ∀ r a. Choose a → Run (choose ∷ CHOOSE | r) a
liftChoose = lift _choose

instance runAlt ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Alt (Run r1) where
  alt a b = fromRows $ liftChoose (Alt identity) >>= if _ then toRows a else toRows b

instance runPlus ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Plus (Run r1) where
  empty = fromRows $ liftChoose Empty

instance runAlternative ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Alternative (Run r1)


Add foldTree function

Add foldTree function

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b o m =
    Atom      m  a
  | List      m (List (Tree a b o m))
  | NTuple    m (List (Tree a b o m))
  | Binary    m o (Tree a b o m) (Tree a b o m)
  | Unary     m o (Tree a b o m)
  | SectL     m (Tree a b o m) o
  | SectR     m o (Tree a b o m)
  | PrefixOp  m o
  | IfExpr    m (Tree a b o m) (Tree a b o m) (Tree a b o m)
  | ArithmSeq m (Tree a b o m) (Maybe (Tree a b o m)) (Maybe (Tree a b o m))
  | LetExpr   m (List (Tuple b (Tree a b o m))) (Tree a b o m)
  | Lambda    m (List b) (Tree a b o m)
  | App       m (Tree a b o m) (List (Tree a b o m))
  | ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))

data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

foldTree :: forall a b o m u v.
                      (m -> a -> u)
                   -> (m -> List u -> u)
                   -> (m -> List u -> u)
                   -> (m -> o -> u -> u -> u)
                   -> (m -> o -> u -> u)
                   -> (m -> u -> o -> u)
                   -> (m -> o -> u -> u)
                   -> (m -> o -> u)
                   -> (m -> u -> u -> u -> u)
                   -> (m -> u -> Maybe u -> Maybe u -> u)
                   -> (m -> List (Tuple b u) -> u -> u)
                   -> (m -> List b -> u -> u)
                   -> (m -> u -> List u -> u)
                   -> (m -> u -> List v -> u)
                   -> (m -> b -> u -> v)
                   -> (m -> b -> u -> v)
                   -> (m -> u -> v)
                   -> Tree a b o m -> u
foldTree atom list ntuple binary unary sectl sectr prefixop ifexpr arithmseq letexpr lambda app listcomp gen let' guard = go
  where
    go (Atom m a)               = atom m a
    go (List m us)              = list m (go <$> us)
    go (NTuple m us)            = ntuple m (go <$> us)
    go (Binary m o u1 u2)       = binary m o (go u1) (go u2)
    go (Unary m o u)            = unary m o (go u)
    go (SectL m u o)            = sectl m (go u) o
    go (SectR m o u)            = sectr m o (go u)
    go (PrefixOp m o)           = prefixop m o
    go (IfExpr m u1 u2 u3)      = ifexpr m (go u1) (go u2) (go u3)
    go (ArithmSeq m u1 mu2 mu3) = arithmseq m (go u1) (go <$> mu2) (go <$> mu3)
    go (LetExpr m tus u)        = letexpr m (rmap go <$> tus) (go u)
    go (Lambda m bs u)          = lambda m bs (go u)
    go (App m u us)             = app m (go u) (go <$> us)
    go (ListComp m u qs)        = listcomp m (go u) (qual <$> qs)
      where
        qual :: QualTree b (Tree a b o m) m -> v
        qual (Gen m b u) = gen m b (go u)
        qual (Let m b u) = let' m b (go u)
        qual (Guard m u) = guard m (go u)

idFoldTree :: forall a b o m. Tree a b o m -> Tree a b o m
idFoldTree = foldTree Atom List NTuple Binary Unary SectL SectR PrefixOp IfExpr ArithmSeq LetExpr Lambda App ListComp Gen Let Guard

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorTree :: Functor (Tree a b c) where
  map f = foldTree
          (Atom <<< f)
          (List <<< f)
          (NTuple <<< f)
          (Binary <<< f)
          (Unary <<< f)
          (SectL <<< f)
          (SectR <<< f)
          (PrefixOp <<< f)
          (IfExpr <<< f)
          (ArithmSeq <<< f)
          (LetExpr <<< f)
          (Lambda <<< f)
          (App <<< f)
          (ListComp <<< f)
          (Gen <<< f)
          (Let <<< f)
          (Guard <<< f)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

extractType :: TypeTree -> Type
extractType = extract

extractBindingType:: TypeBinding -> Type
extractBindingType (TLit t)         = t
extractBindingType (TConsLit _ _ t) = t
extractBindingType (TListLit _ t)   = t
extractBindingType (TNTupleLit _ t) = t

type Expr = Tree Atom Binding Op Unit
type ExprQual = QualTree Binding Expr Unit

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)

type TypeTree = Tree Unit TypeBinding Type Type

type IndexTree = Tree Unit IBinding Op Int

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
               | IConsLit IBinding IBinding  Int
               | IListLit (List IBinding)    Int
               | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

-- derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

derive instance eqDefintion :: Eq Definition

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

-- instance showQual :: (Show b, Show e) => Show (Qual b e) where
--   show q = case q of
--     Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
--     Let b e -> "Let (" <> show b <> " " <> show e <> ")"
--     Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

-- instance showTypeTree :: Show TypeTree where
--   show (TAtom t) = "(TAtom " <> show t <> ")"
--   show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
--   show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
--   show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
--   show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
--   show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
--   show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
--   show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
--   show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
--   show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
--   show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
--   show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

-- extractType:: TypeTree -> Type
-- extractType (TAtom t)            = t
-- extractType (TListTree _ t)      = t
-- extractType (TNTuple _ t)        = t
-- extractType (TBinary _ _ _ t)    = t
-- extractType (TUnary _ _ t)       = t
-- extractType (TSectL _ _ t)       = t
-- extractType (TSectR _ _ t)       = t
-- extractType (TPrefixOp t)        = t
-- extractType (TIfExpr _ _ _ t)    = t
-- extractType (TArithmSeq _ _ _ t) = t
-- extractType (TLetExpr _ _ t)     = t
-- extractType (TLambda _ _ t)      = t
-- extractType (TApp _ _ t)         = t
-- extractType (TListComp _ _ t)    = t

-- extractIndex :: IndexTree -> Int
-- extractIndex (IAtom i)            = i
-- extractIndex (IListTree _ i)      = i
-- extractIndex (INTuple _ i)        = i
-- extractIndex (IBinary _ _ _ i)    = i
-- extractIndex (IUnary _ _ i)       = i
-- extractIndex (ISectL _ _ i)       = i
-- extractIndex (ISectR _ _ i)       = i
-- extractIndex (IPrefixOp i)        = i
-- extractIndex (IIfExpr _ _ _ i)    = i
-- extractIndex (IArithmSeq _ _ _ i) = i
-- extractIndex (ILetExpr _ _ i)     = i
-- extractIndex (ILambda _ _ i)      = i
-- extractIndex (IApp _ _ i)         = i
-- extractIndex (IListComp _ _ i)    = i

-- extractBindingType:: TypeBinding -> Type
-- extractBindingType (TLit t)         = t
-- extractBindingType (TConsLit _ _ t) = t
-- extractBindingType (TListLit _ t)   = t
-- extractBindingType (TNTupleLit _ t) = t

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b c d =
    Atom      d a
  | List      d (List (Tree a b c d))
  | NTuple    d (List (Tree a b c d))
  | Binary    d c (Tree a b c d) (Tree a b c d)
  | Unary     d c (Tree a b c d)
  | SectL     d (Tree a b c d) c
  | SectR     d c (Tree a b c d)
  | PrefixOp  d c
  | IfExpr    d (Tree a b c d) (Tree a b c d) (Tree a b c d)
  | ArithmSeq d (Tree a b c d) (Maybe (Tree a b c d)) (Maybe (Tree a b c d))
  | LetExpr   d (List (Tuple b (Tree a b c d))) (Tree a b c d)
  | Lambda    d (List b) (Tree a b c d)
  | App       d (Tree a b c d) (List (Tree a b c d))
  | ListComp  d (Tree a b c d) (List (QualTree b (Tree a b c d) d))

data QualTree b e d = Gen d b e
                    | Let d b e
                    | Guard d e

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorQualTree :: Functor (QualTree b e) where
  map f (Gen d b e) = Gen (f d) b e
  map f (Let d b e) = Let (f d) b e
  map f (Guard d e) = Guard (f d) e

instance functorTree :: Functor (Tree a b c) where
  map f (Atom c a) = Atom (f c) a
  map f (List c xs) = List (f c) (map f <$> xs)
  map f (NTuple c xs) = List (f c) (map f <$> xs)
  map f (Binary c op t1 t2) = Binary (f c) op (map f t1) (map f t2)
  map f (Unary c op t) = Unary (f c) op (map f t)
  map f (SectL c t op) = SectL (f c) (map f t) op
  map f (SectR c op t) = SectR (f c) op (map f t)
  map f (PrefixOp c op) = PrefixOp (f c) op
  map f (IfExpr c t1 t2 t3) = IfExpr (f c) (map f t1) (map f t2) (map f t3)
  map f (ArithmSeq c t1 t2 t3) = ArithmSeq (f c) (map f t1) (map f <$> t2) (map f <$> t3)
  map f (LetExpr c bs t) = LetExpr (f c) (map (rmap (map f)) bs) (map f t)
  map f (Lambda c bs t) = Lambda (f c) bs (map f t)
  map f (App c t ts) = App (f c) (map f t) (map f <$> ts)
  map f (ListComp c t ts) = ListComp (f c) (map f t) (map go ts)
    where
    go (Gen d b e) = Gen (f d) b (map f e)
    go (Let d b e) = Let (f d) b (map f e)
    go (Guard d e) = Guard (f d) (map f e)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

extractType :: TypeTree -> Type
extractType = extract

extractBindingType:: TypeBinding -> Type
extractBindingType (TLit t)         = t
extractBindingType (TConsLit _ _ t) = t
extractBindingType (TListLit _ t)   = t
extractBindingType (TNTupleLit _ t) = t

type Expr = Tree Atom Binding Op Unit
type ExprQual = QualTree Binding Expr Unit

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)

type TypeTree = Tree Unit TypeBinding Type Type

type IndexTree = Tree Unit IBinding Op Int

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
               | IConsLit IBinding IBinding  Int
               | IListLit (List IBinding)    Int
               | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

-- derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

derive instance eqDefintion :: Eq Definition

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

-- instance showQual :: (Show b, Show e) => Show (Qual b e) where
--   show q = case q of
--     Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
--     Let b e -> "Let (" <> show b <> " " <> show e <> ")"
--     Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

-- instance showTypeTree :: Show TypeTree where
--   show (TAtom t) = "(TAtom " <> show t <> ")"
--   show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
--   show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
--   show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
--   show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
--   show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
--   show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
--   show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
--   show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
--   show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
--   show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
--   show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

-- extractType:: TypeTree -> Type
-- extractType (TAtom t)            = t
-- extractType (TListTree _ t)      = t
-- extractType (TNTuple _ t)        = t
-- extractType (TBinary _ _ _ t)    = t
-- extractType (TUnary _ _ t)       = t
-- extractType (TSectL _ _ t)       = t
-- extractType (TSectR _ _ t)       = t
-- extractType (TPrefixOp t)        = t
-- extractType (TIfExpr _ _ _ t)    = t
-- extractType (TArithmSeq _ _ _ t) = t
-- extractType (TLetExpr _ _ t)     = t
-- extractType (TLambda _ _ t)      = t
-- extractType (TApp _ _ t)         = t
-- extractType (TListComp _ _ t)    = t

-- extractIndex :: IndexTree -> Int
-- extractIndex (IAtom i)            = i
-- extractIndex (IListTree _ i)      = i
-- extractIndex (INTuple _ i)        = i
-- extractIndex (IBinary _ _ _ i)    = i
-- extractIndex (IUnary _ _ i)       = i
-- extractIndex (ISectL _ _ i)       = i
-- extractIndex (ISectR _ _ i)       = i
-- extractIndex (IPrefixOp i)        = i
-- extractIndex (IIfExpr _ _ _ i)    = i
-- extractIndex (IArithmSeq _ _ _ i) = i
-- extractIndex (ILetExpr _ _ i)     = i
-- extractIndex (ILambda _ _ i)      = i
-- extractIndex (IApp _ _ i)         = i
-- extractIndex (IListComp _ _ i)    = i

-- extractBindingType:: TypeBinding -> Type
-- extractBindingType (TLit t)         = t
-- extractBindingType (TConsLit _ _ t) = t
-- extractBindingType (TListLit _ t)   = t
-- extractBindingType (TNTupleLit _ t) = t