Added fromCharCode.

Added fromCharCode.

module Data.String where

foreign import charAt
  "function charAt(i) {\
  \  return function(s) {\
  \    return s.charAt(i); \
  \  };\
  \}" :: Number -> String -> String

foreign import fromCharCode
  "function fromCharCode(n) {\
  \  return String.fromCharCode(n);\
  \}" :: Number -> String

foreign import indexOfS
  "function indexOfS(s1) {\
  \  return function(s2) {\
  \    return s1.indexOf(s2);\
  \  }; \
  \}" :: String -> String -> Number

foreign import lastIndexOfS
  "function lastIndexOfS(s1) {\
  \  return function(s2) {\
  \    return s1.lastIndexOf(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import lengthS
  "function lengthS(s) {\
  \  return s.length;\
  \}" :: String -> Number

foreign import localeCompare
  "function localeCompare(s1) {\
  \  return function(s2) {\
  \    return s1.localeCompare(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import replace
  "function replace(s1) {\
  \  return function(s2) {\
  \    return function(s3) {\
  \      return s3.replace(s1, s2);\
  \    };\
  \  };\
  \}" :: String -> String -> String -> String

foreign import sliceS
  "function sliceS(st) {\
  \  return function(e) {\
  \    return function(s) {\
  \      return s.slice(st, e);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import split
  "function split(sep) {\
  \  return function(s) {\
  \    return s.split(sep);\
  \  };\
  \}" :: String -> String -> [String]

foreign import substr
  "function substr(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substr(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import substring
  "function substring(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substring(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import toLower
  "function toLower(s) {\
  \  return s.toLowerCase();\
  \}" :: String -> String

foreign import toUpper
  "function toUpper(s) {\
  \  return s.toUpperCase();\
  \}" :: String -> String

foreign import trim
  "function trim(s) {\
  \  return s.trim();\
  \}" :: String -> String

module Data.String where

foreign import lengthS
  "function lengthS(s) {\
  \  return s.length;\
  \}" :: String -> Number

foreign import charAt
  "function charAt(i) {\
  \  return function(s) {\
  \    return s.charAt(i); \
  \  };\
  \}" :: Number -> String -> String

foreign import indexOfS
  "function indexOfS(s1) {\
  \  return function(s2) {\
  \    return s1.indexOf(s2);\
  \  }; \
  \}" :: String -> String -> Number

foreign import lastIndexOfS
  "function lastIndexOfS(s1) {\
  \  return function(s2) {\
  \    return s1.lastIndexOf(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import localeCompare
  "function localeCompare(s1) {\
  \  return function(s2) {\
  \    return s1.localeCompare(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import replace
  "function replace(s1) {\
  \  return function(s2) {\
  \    return function(s3) {\
  \      return s3.replace(s1, s2);\
  \    };\
  \  };\
  \}" :: String -> String -> String -> String

foreign import sliceS
  "function sliceS(st) {\
  \  return function(e) {\
  \    return function(s) {\
  \      return s.slice(st, e);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import split
  "function split(sep) {\
  \  return function(s) {\
  \    return s.split(sep);\
  \  };\
  \}" :: String -> String -> [String]

foreign import substr
  "function substr(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substr(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import substring
  "function substring(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substring(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import toLower
  "function toLower(s) {\
  \  return s.toLowerCase();\
  \}" :: String -> String

foreign import toUpper
  "function toUpper(s) {\
  \  return s.toUpperCase();\
  \}" :: String -> String

foreign import trim
  "function trim(s) {\
  \  return s.trim();\
  \}" :: String -> String


Add (:) to prelude

Add (:) to prelude

module Prelude where

  id :: forall a. a -> a
  id = \x -> x

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip = \f -> \b -> \a -> f a b

  konst :: forall a b. a -> b -> a
  konst = \a -> \b -> a

  (|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c
  (|>) = \f -> \g -> \a -> g (f a)

  (<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
  (<|) = flip (|>)

module Maybe where

  data Maybe a = Nothing | Just a

  maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
  maybe b _ Nothing = b
  maybe _ f (Just a) = f a

  fromMaybe :: forall a. a -> Maybe a -> a
  fromMaybe a = maybe a Prelude.id

  bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
  bindMaybe m f = maybe Nothing f m

module Either where

  data Either a b = Left a | Right b

  either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
  either f _ (Left a) = f a
  either _ g (Right b) = g b

  bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
  bindEither = either (\e _ -> Left e) (\a f -> f a)

module Arrays where

  import Maybe

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

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

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

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

  foreign import map :: forall a b. (a -> b) -> [a] -> [b]

  foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
  foldr f a (b : bs) = f (foldr f a bs) b
  foldr _ a [] = a

  foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
  foldl f b as = {
      var result = b;
      foreach (a in as) {
	result = f a result;
      }
      return result;
    }

  foreign import member "length" length :: forall a. [a] -> Number

  foreign import indexOf :: forall a. [a] -> a -> Number

  foreign import lastIndexOf :: forall a. [a] -> a -> Number

  foreign import concat :: forall a. [a] -> [a] -> [a]

  foreign import join :: [String] -> String

  foreign import joinWith :: [String] -> String -> String

  foreign import push :: forall a. [a] -> a -> [a]

  foreign import reverse :: forall a. [a] -> [a]

  foreign import shift :: forall a. [a] -> [a]

  foreign import slice :: forall a. Number -> Number -> [a] -> [a]

  foreign import sort :: forall a. [a] -> [a]

  foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]

  infixr 6 :

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

  concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
  concatMap as f = {
      var result = [];
      foreach (a in as) {
	result = result `concat` f a;
      }
      return result;
    }

  foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]

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

  range :: Number -> Number -> [Number]
  range lo hi = {
      var ns = [];
      for (n <- lo until hi) {
	ns = push ns n;
      }
      return ns;
    }

  zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
  zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
  zipWith _ _ _ = []

  any :: forall a. (a -> Boolean) -> [a] -> Boolean
  any p as = {
      for (i <- 0 until length as) {
	if (p (as !! i)) {
	  return true;
	}
      }
      return false;
    }

  all :: forall a. (a -> Boolean) -> [a] -> Boolean
  all p as = {
      for (i <- 0 until length as) {
	if (!(p (as !! i))) {
	  return false;
	}
      }
      return true;
    }

module Tuple where

  import Arrays

  type Tuple a b = { fst :: a, snd :: b }

  curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
  curry f a b = f { fst: a, snd: b }

  uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
  uncurry f t = f t.fst t.snd

  tuple :: forall a b. a -> b -> Tuple a b
  tuple = curry Prelude.id

  zip :: forall a b. [a] -> [b] -> [Tuple a b]
  zip = zipWith tuple

  unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
  unzip (t:ts) = case unzip ts of
      { fst = as, snd = bs } -> tuple (t.fst : as) (t.snd : bs)
  unzip [] = tuple [] []

module String where

  foreign import member "length" lengthS :: String -> Number

  foreign import charAt :: Number -> String -> String

  foreign import indexOfS :: String -> String -> Number

  foreign import lastIndexOfS :: String -> String -> Number

  foreign import localeCompare :: String -> String -> Number

  foreign import replace :: String -> String -> String -> String

  foreign import sliceS :: Number -> Number -> String -> String

  foreign import split :: String -> String -> [String]

  foreign import substr :: Number -> Number -> String -> String

  foreign import substring :: Number -> Number -> String -> String

  foreign import toLower :: String -> String

  foreign import toUpper :: String -> String

  foreign import trim :: String -> String

module Regex where

  foreign import data Regex :: *

  foreign import regex :: String -> String -> Regex

  foreign import test :: Regex -> String -> Boolean

  foreign import match :: Regex -> String -> [String]

  foreign import replaceR :: Regex -> String -> String -> String

  foreign import search :: Regex -> String -> Number

module Global where

  foreign import nan :: Number

  foreign import infinity :: Number

  foreign import toExponential :: Number -> String

  foreign import toFixed :: Number -> Number -> String

  foreign import toPrecision :: Number -> Number -> String

  foreign import numberToString :: Number -> String

  foreign import isNaN :: Number -> Boolean

  foreign import isFinite :: Number -> Boolean

  foreign import parseFloat :: String -> Number

  foreign import parseInt :: String -> Number

  foreign import encodeURIComponent :: String -> String

  foreign import decodeURIComponent :: String -> String

  foreign import encodeURI :: String -> String

  foreign import decodeURI :: String -> String

module Math where

  type Math =
    { abs :: Number -> Number
    , acos :: Number -> Number
    , asin :: Number -> Number
    , atan :: Number -> Number
    , atan2 :: (Number, Number) -> Number
    , aceil :: Number -> Number
    , cos :: Number -> Number
    , exp :: Number -> Number
    , floor :: Number -> Number
    , log :: Number -> Number
    , max :: (Number, Number) -> Number
    , pow :: (Number, Number) -> Number
    , random :: () -> Number
    , round :: Number -> Number
    , sin :: Number -> Number
    , sqrt :: Number -> Number
    , tan :: Number -> Number
    }

  foreign import math :: Math

module Prelude where

  id :: forall a. a -> a
  id = \x -> x

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip = \f -> \b -> \a -> f a b

  konst :: forall a b. a -> b -> a
  konst = \a -> \b -> a

  (|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c
  (|>) = \f -> \g -> \a -> g (f a)

  (<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
  (<|) = flip (|>)

module Maybe where

  data Maybe a = Nothing | Just a

  maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
  maybe b _ Nothing = b
  maybe _ f (Just a) = f a

  fromMaybe :: forall a. a -> Maybe a -> a
  fromMaybe a = maybe a Prelude.id

  bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
  bindMaybe m f = maybe Nothing f m

module Either where

  data Either a b = Left a | Right b

  either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
  either f _ (Left a) = f a
  either _ g (Right b) = g b

  bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
  bindEither = either (\e _ -> Left e) (\a f -> f a)

module Arrays where

  import Maybe

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

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

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

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

  foreign import map :: forall a b. (a -> b) -> [a] -> [b]

  foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
  foldr f a (b : bs) = f (foldr f a bs) b
  foldr _ a [] = a

  foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
  foldl f b as = {
      var result = b;
      foreach (a in as) {
	result = f a result;
      }
      return result;
    }

  foreign import member "length" length :: forall a. [a] -> Number

  foreign import indexOf :: forall a. [a] -> a -> Number

  foreign import lastIndexOf :: forall a. [a] -> a -> Number

  foreign import concat :: forall a. [a] -> [a] -> [a]

  foreign import join :: [String] -> String

  foreign import joinWith :: [String] -> String -> String

  foreign import push :: forall a. [a] -> a -> [a]

  foreign import reverse :: forall a. [a] -> [a]

  foreign import shift :: forall a. [a] -> [a]

  foreign import slice :: forall a. Number -> Number -> [a] -> [a]

  foreign import sort :: forall a. [a] -> [a]

  foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]

  cons :: forall a. a -> [a] -> [a]
  cons a = concat [a]

  concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
  concatMap as f = {
      var result = [];
      foreach (a in as) {
	result = result `concat` f a;
      }
      return result;
    }

  foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]

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

  range :: Number -> Number -> [Number]
  range lo hi = {
      var ns = [];
      for (n <- lo until hi) {
	ns = push ns n;
      }
      return ns;
    }

  zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
  zipWith f (a:as) (b:bs) = cons (f a b) (zipWith f as bs)
  zipWith _ _ _ = []

  any :: forall a. (a -> Boolean) -> [a] -> Boolean
  any p as = {
      for (i <- 0 until length as) {
	if (p (as !! i)) {
	  return true;
	}
      }
      return false;
    }

  all :: forall a. (a -> Boolean) -> [a] -> Boolean
  all p as = {
      for (i <- 0 until length as) {
	if (!(p (as !! i))) {
	  return false;
	}
      }
      return true;
    }

module Tuple where

  import Arrays

  type Tuple a b = { fst :: a, snd :: b }

  curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
  curry f a b = f { fst: a, snd: b }

  uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
  uncurry f t = f t.fst t.snd

  tuple :: forall a b. a -> b -> Tuple a b
  tuple = curry Prelude.id

  zip :: forall a b. [a] -> [b] -> [Tuple a b]
  zip = zipWith tuple

  unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
  unzip (t:ts) = case unzip ts of
      { fst = as, snd = bs } -> tuple (cons t.fst as) (cons t.snd bs)
  unzip [] = tuple [] []

module String where

  foreign import member "length" lengthS :: String -> Number

  foreign import charAt :: Number -> String -> String

  foreign import indexOfS :: String -> String -> Number

  foreign import lastIndexOfS :: String -> String -> Number

  foreign import localeCompare :: String -> String -> Number

  foreign import replace :: String -> String -> String -> String

  foreign import sliceS :: Number -> Number -> String -> String

  foreign import split :: String -> String -> [String]

  foreign import substr :: Number -> Number -> String -> String

  foreign import substring :: Number -> Number -> String -> String

  foreign import toLower :: String -> String

  foreign import toUpper :: String -> String

  foreign import trim :: String -> String

module Regex where

  foreign import data Regex :: *

  foreign import regex :: String -> String -> Regex

  foreign import test :: Regex -> String -> Boolean

  foreign import match :: Regex -> String -> [String]

  foreign import replaceR :: Regex -> String -> String -> String

  foreign import search :: Regex -> String -> Number

module Global where

  foreign import nan :: Number

  foreign import infinity :: Number

  foreign import toExponential :: Number -> String

  foreign import toFixed :: Number -> Number -> String

  foreign import toPrecision :: Number -> Number -> String

  foreign import numberToString :: Number -> String

  foreign import isNaN :: Number -> Boolean

  foreign import isFinite :: Number -> Boolean

  foreign import parseFloat :: String -> Number

  foreign import parseInt :: String -> Number

  foreign import encodeURIComponent :: String -> String

  foreign import decodeURIComponent :: String -> String

  foreign import encodeURI :: String -> String

  foreign import decodeURI :: String -> String

module Math where

  type Math =
    { abs :: Number -> Number
    , acos :: Number -> Number
    , asin :: Number -> Number
    , atan :: Number -> Number
    , atan2 :: (Number, Number) -> Number
    , aceil :: Number -> Number
    , cos :: Number -> Number
    , exp :: Number -> Number
    , floor :: Number -> Number
    , log :: Number -> Number
    , max :: (Number, Number) -> Number
    , pow :: (Number, Number) -> Number
    , random :: () -> Number
    , round :: Number -> Number
    , sin :: Number -> Number
    , sqrt :: Number -> Number
    , tan :: Number -> Number
    }

  foreign import math :: Math


Made state effectful

Made state effectful

module AppState
    ( AppStateM
    , run
    ) where

import Prelude
    ( class Functor, class Apply, class Applicative, class Bind, class Monad
    , Unit
    , const, pure, unit, bind
    , ($), (<$>), (>>=), (==), (<*>), (<>)
    )
import Effect (Effect)
import Effect.Ref (Ref, new, read, modify_)
import Data.Array as A
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Either (Either(..))
import Control.Monad.Reader.Trans (ReaderT, runReaderT, asks, lift)

import Hand as H
import Capabilities
    ( ScoredHand, ScoredSelectedHand
    , clear, error, errors
    , class Edit, class GetHands, class Error, class Nav, class ReadError
    )

data HandList
    = NewHand { editing :: H.Hand, scored :: Array ScoredHand }
    | Editing { editing :: H.Hand, scored :: Array ScoredSelectedHand }
    | NotEditing { scored :: Array ScoredHand }

type AppState =
    { hands :: HandList
    , error :: Maybe (Array String)
    }

start :: AppState
start = { hands : NotEditing { scored : [] }, error : Nothing }

newtype AppStateM x = AppStateM (ReaderT (Ref AppState) Effect x)

derive newtype instance functorAppStateM :: Functor AppStateM
derive newtype instance applyAppStateM :: Apply AppStateM
derive newtype instance applicativeAppStateM :: Applicative AppStateM
derive newtype instance bindAppStateM :: Bind AppStateM
derive newtype instance monadAppStateM :: Monad AppStateM

get :: AppStateM AppState
get = AppStateM $ asks >>= lift read

modify :: (AppState -> AppState) -> AppStateM Unit
modify f = AppStateM $ do
    ref <- asks
    lift $ modify_ f ref

put :: AppState -> AppStateM Unit
put a = modify (const a)

run :: forall x. AppStateM x -> Effect x
run (AppStateM f) = new start >>= runReaderT f

instance getHandsAppStateM :: GetHands AppStateM where
    getAll = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> pure $
            ( \{score, hand} -> {score, hand, selected : false} ) <$> scored
        Editing {editing, scored} -> pure scored
        NotEditing {scored} -> pure $
            ( \{score, hand} -> {score, hand, selected : false} ) <$> scored
    isNewHand = get >>= \state -> case state.hands of
        NewHand _ -> pure true
        _ -> pure false
    isEdit = get >>= \state -> case state.hands of
        NewHand _ -> pure true
        Editing _ -> pure true
        _ -> pure false

instance errorAppStateM :: Error AppStateM where
    errors e = modify $ _ { error = Just e }
    clear = modify $ _ { error = Nothing }

instance navAppStateM :: Nav AppStateM where
    newHand = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> put
            { hands : NewHand $ {editing : H.newHand, scored }
            , error : Nothing
            }
        Editing {editing, scored} -> put
            { hands : NewHand $
                { editing : H.newHand
                , scored : (\{selected,hand,score}->{hand,score}) <$> scored
                }
            , error : Nothing
            }
        NotEditing {scored} -> put
            { hands : NewHand {editing : H.newHand, scored}
            , error : Nothing
            }
    editHand i = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> case A.index scored i of
            Just newEdit -> put
                { hands : Editing
                    { editing : newEdit.hand
                    , scored : A.mapWithIndex ( \j {hand, score} ->
                        {hand, score, selected : i == j} ) scored
                    }
                , error : Nothing
                }
            Nothing -> error "Cannot edit hand, index out of range"
        Editing {editing, scored} -> case A.index scored i of
            Just newEdit | newEdit.selected -> pure unit
            Just newEdit -> put
                { hands : Editing
                    { editing : newEdit.hand
                    , scored : A.mapWithIndex ( \j {hand, score, selected} ->
                        {hand, score, selected : i == j} ) scored
                    }
                , error : Nothing
                }
            Nothing -> error "Cannot edit hand, index out of range"
        NotEditing {scored} -> case A.index scored i of
            Just editing -> put
                { hands : Editing
                    { editing : editing.hand
                    , scored : A.mapWithIndex ( \j {hand, score} ->
                        {hand, score, selected : i == j} ) scored
                    }
                , error : Nothing
                }
            Nothing -> error "Cannot edit hand, index out of range"
    delHand i = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> case A.deleteAt i scored of
            Nothing -> error "Cannot delete hand, index out of range"
            Just newS -> put
                { hands : NewHand {editing, scored : newS}, error : Nothing }
        Editing {editing, scored} ->
            case Tuple <$> A.index scored i <*> A.deleteAt i scored of
                Just (Tuple t newS) | t.selected -> put
                    { hands : NotEditing { scored : (\{selected, hand, score} ->
                        {hand, score}) <$> newS }
                    , error : Nothing
                    }
                Just (Tuple _ newS) -> put
                    { hands : Editing { editing, scored : newS }
                    , error : Nothing
                    }
                Nothing -> error "Cannot delete hand, index out of range"
        NotEditing {scored} -> case A.deleteAt i scored of
            Just newS -> put
                { hands : NotEditing {scored : newS}
                , error : Nothing
                }
            Nothing -> error "Cannot delete hand, index out of range"

instance editAppStateM :: Edit AppStateM where
    getEdit = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> pure $ Just editing
        Editing {editing, scored} -> pure $ Just editing
        NotEditing _ -> pure Nothing
    adjust f = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> modify $
            _ { hands = NewHand {editing : f editing, scored } }
        Editing {editing, scored} -> modify $
            _ { hands = Editing {editing : f editing, scored } }
        NotEditing _ -> clear
    submit = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> case H.scoreHand editing of
            Left e -> errors e
            Right score -> put
                { hands : NotEditing
                    { scored : [{hand : editing, score}] <> scored }
                , error : Nothing
                }
        Editing {editing, scored} -> case H.scoreHand editing of
            Left e -> errors e
            Right nscore -> put
                { hands : NotEditing
                    { scored : ( ( \{hand, score, selected} ->
                            if selected then
                                {hand : editing, score : nscore}
                            else
                                {hand, score} ) <$> scored
                        )
                    }
                , error : Nothing
                }
        NotEditing _ -> clear
    revert = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> put
            {hands : NotEditing {scored}, error : Nothing}
        Editing {editing, scored} -> put
            { hands : NotEditing { scored : ( \{selected, hand, score} ->
                {hand, score} ) <$> scored }
            , error : Nothing
            }
        NotEditing _ -> clear

instance readErrorAppStateM :: ReadError AppStateM where
    readError = _.error <$> get

module AppState
    ( AppStateM
    , run
    ) where

import Prelude
    ( class Functor, class Apply, class Applicative, class Bind, class Monad
    , Unit
    , const, pure, unit
    , ($), (<$>), (>>=), (==), (<*>), (<>)
    )
import Control.Monad.State as S
import Data.Array as A
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), fst)
import Data.Either (Either(..))

import Hand as H
import Capabilities
    ( ScoredHand, ScoredSelectedHand
    , clear, error, errors
    , class Edit, class GetHands, class Error, class Nav, class ReadError
    )

data HandList
    = NewHand { editing :: H.Hand, scored :: Array ScoredHand }
    | Editing { editing :: H.Hand, scored :: Array ScoredSelectedHand }
    | NotEditing { scored :: Array ScoredHand }

type AppState =
    { hands :: HandList
    , error :: Maybe (Array String)
    }

start :: AppState
start = { hands : NotEditing { scored : [] }, error : Nothing }

newtype AppStateM x = AppStateM (S.State AppState x)

derive newtype instance functorAppStateM :: Functor AppStateM
derive newtype instance applyAppStateM :: Apply AppStateM
derive newtype instance applicativeAppStateM :: Applicative AppStateM
derive newtype instance bindAppStateM :: Bind AppStateM
derive newtype instance monadAppStateM :: Monad AppStateM

get :: AppStateM AppState
get = AppStateM S.get

modify :: (AppState -> AppState) -> AppStateM Unit
modify f = AppStateM $ S.modify_ f

put :: AppState -> AppStateM Unit
put a = modify (const a)

run :: forall x. AppStateM x -> x
run (AppStateM s) = fst $ S.runState s start

instance getHandsAppStateM :: GetHands AppStateM where
    getAll = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> pure $
            ( \{score, hand} -> {score, hand, selected : false} ) <$> scored
        Editing {editing, scored} -> pure scored
        NotEditing {scored} -> pure $
            ( \{score, hand} -> {score, hand, selected : false} ) <$> scored
    isNewHand = get >>= \state -> case state.hands of
        NewHand _ -> pure true
        _ -> pure false
    isEdit = get >>= \state -> case state.hands of
        NewHand _ -> pure true
        Editing _ -> pure true
        _ -> pure false

instance errorAppStateM :: Error AppStateM where
    errors e = modify $ _ { error = Just e }
    clear = modify $ _ { error = Nothing }

instance navAppStateM :: Nav AppStateM where
    newHand = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> put
            { hands : NewHand $ {editing : H.newHand, scored }
            , error : Nothing
            }
        Editing {editing, scored} -> put
            { hands : NewHand $
                { editing : H.newHand
                , scored : (\{selected,hand,score}->{hand,score}) <$> scored
                }
            , error : Nothing
            }
        NotEditing {scored} -> put
            { hands : NewHand {editing : H.newHand, scored}
            , error : Nothing
            }
    editHand i = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> case A.index scored i of
            Just newEdit -> put
                { hands : Editing
                    { editing : newEdit.hand
                    , scored : A.mapWithIndex ( \j {hand, score} ->
                        {hand, score, selected : i == j} ) scored
                    }
                , error : Nothing
                }
            Nothing -> error "Cannot edit hand, index out of range"
        Editing {editing, scored} -> case A.index scored i of
            Just newEdit | newEdit.selected -> pure unit
            Just newEdit -> put
                { hands : Editing
                    { editing : newEdit.hand
                    , scored : A.mapWithIndex ( \j {hand, score, selected} ->
                        {hand, score, selected : i == j} ) scored
                    }
                , error : Nothing
                }
            Nothing -> error "Cannot edit hand, index out of range"
        NotEditing {scored} -> case A.index scored i of
            Just editing -> put
                { hands : Editing
                    { editing : editing.hand
                    , scored : A.mapWithIndex ( \j {hand, score} ->
                        {hand, score, selected : i == j} ) scored
                    }
                , error : Nothing
                }
            Nothing -> error "Cannot edit hand, index out of range"
    delHand i = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> case A.deleteAt i scored of
            Nothing -> error "Cannot delete hand, index out of range"
            Just newS -> put
                { hands : NewHand {editing, scored : newS}, error : Nothing }
        Editing {editing, scored} ->
            case Tuple <$> A.index scored i <*> A.deleteAt i scored of
                Just (Tuple t newS) | t.selected -> put
                    { hands : NotEditing { scored : (\{selected, hand, score} ->
                        {hand, score}) <$> newS }
                    , error : Nothing
                    }
                Just (Tuple _ newS) -> put
                    { hands : Editing { editing, scored : newS }
                    , error : Nothing
                    }
                Nothing -> error "Cannot delete hand, index out of range"
        NotEditing {scored} -> case A.deleteAt i scored of
            Just newS -> put
                { hands : NotEditing {scored : newS}
                , error : Nothing
                }
            Nothing -> error "Cannot delete hand, index out of range"

instance editAppStateM :: Edit AppStateM where
    getEdit = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> pure $ Just editing
        Editing {editing, scored} -> pure $ Just editing
        NotEditing _ -> pure Nothing
    adjust f = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> modify $
            _ { hands = NewHand {editing : f editing, scored } }
        Editing {editing, scored} -> modify $
            _ { hands = Editing {editing : f editing, scored } }
        NotEditing _ -> clear
    submit = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> case H.scoreHand editing of
            Left e -> errors e
            Right score -> put
                { hands : NotEditing
                    { scored : [{hand : editing, score}] <> scored }
                , error : Nothing
                }
        Editing {editing, scored} -> case H.scoreHand editing of
            Left e -> errors e
            Right nscore -> put
                { hands : NotEditing
                    { scored : ( ( \{hand, score, selected} ->
                            if selected then
                                {hand : editing, score : nscore}
                            else
                                {hand, score} ) <$> scored
                        )
                    }
                , error : Nothing
                }
        NotEditing _ -> clear
    revert = get >>= \state -> case state.hands of
        NewHand {editing, scored} -> put
            {hands : NotEditing {scored}, error : Nothing}
        Editing {editing, scored} -> put
            { hands : NotEditing { scored : ( \{selected, hand, score} ->
                {hand, score} ) <$> scored }
            , error : Nothing
            }
        NotEditing _ -> clear

instance readErrorAppStateM :: ReadError AppStateM where
    readError = _.error <$> get


Comment invalid test

Comment invalid test

module Test.Evaluator where

import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
-- import Data.List (List, singleton)

-- import Control.Monad.Writer (Writer, tell)

import Parser (definitions, expression, runParserIndent)
import Evaluator (eval, eval1, runEvalM, defsToEnv)
import Test.Parser (prelude)

import Test.Utils (Test, tell, padLeft)

tell' :: String -> Test Unit
tell' = tell

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right inExp) (Right expExp)) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" ++ name ++ ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

eval1EnvTest :: String -> String -> String -> String -> Test Unit
eval1EnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" <> name <> ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

evalEnvTest :: String -> String -> String -> String -> Test Unit
evalEnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp == expExp
        then pure unit -- log $ "Eval success (" ++ name ++ ")"
        else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input String:\n"
            <> padLeft input <> "\n"
            <> "Input Parsed:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show evalExp) <> "\n"
            <> "Expected String:\n"
            <> padLeft expected <> "\n"
            <> "Expected Parsed:\n"
            <> padLeft (show expExp) <> "\n"
            <> "Definitions String:\n"
            <> padLeft env <> "\n"
            <> "Definitions Parsed:\n"
            <> padLeft (show defs)
  (Tuple (Tuple pi pe) pd) -> tell'
     $ "Parse fail (" <> name <> "):\n"
    <> "Input:\n"
    <> padLeft (show pi) <> "\n"
    <> "Expected:\n"
    <> padLeft (show pe) <> "\n"
    <> "Definitions:\n"
    <> padLeft (show pd)

runTests :: Test Unit
runTests = do
  eval1test "add" "1+1" "2"
  eval1test "power" "2^10" "1024"
  eval1test "append" "[1] ++ [2]" "[1, 2]"
  eval1test "cons" "True:[]" "[True]"
  eval1test "lambda" "(\\a b -> a + b) 1 2" "1 + 2"
  eval1test "section1" "(*5) 7" "7 * 5"
  eval1test "section2" "(10<) 8" "10 < 8"
  eval1test "prefix" "(&&) True True" "True && True"
  eval1test "if_then_else" "if True then 42 else 0" "42"
  eval1test "pattern_matching1" "(\\(x:xs) -> x) [1, 2, 3]" "1"
  eval1test "pattern_matching2" "(\\[a, b, c] -> c) [1, 2, 3]" "3"
  eval1test "pattern_matching3" "(\\(a, b) (c, d, e) -> d) (1, 2) (3, 2*2, 5)" "2*2"
  eval1test "lambda2" "(\\x y -> [0, x, y, x + y]) 1 2" "[0, 1, 2, 1 + 2]"
  eval1test "string1" "\"as\" ++ \"df\"" "\"asdf\""
  eval1test "string2" "'a' : \"sdf\"" "\"asdf\""

  eval1EnvTest "double_func" "double x = x + x" "double 10" "10 + 10"
  eval1EnvTest "map_func1" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) []" "[]"
  eval1EnvTest "map_func2" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) [1, 2, 3]" "(^2) 1 : map (^2) [2, 3]"

  evalEnvTest "evalAll1" "" "1 + 2 + 3" "6"
  evalEnvTest "evalAll2" "" "(2^10) > (10^2)" "True"
  evalEnvTest "evalAll3" "" "3" "3"
  evalEnvTest "evalAll4" "" "x + y" "x + y"
  evalEnvTest "evalAll5" "" "(2 * 5) * x + 2 ^ 3" "10 * x + 8"
  evalEnvTest "evalAll6" "" "1 / 0" "1 / 0"

  evalEnvTest "evalNegNumber1" "" "(-3) - (-4)" "1"
  evalEnvTest "evalNegNumber2" "" "(-2) * (-2)" "4"
  evalEnvTest "evalNegNumber3" "" "-(-(5*5) + 6*6) + 7*7" (show (-(-(5*5) + 6*6) + 7*7)) -- 38
  evalEnvTest "evalNegNumber4" "" "-3 * 7 + 23" "2"

  evalEnvTest "if1" "" "if 10 > 5 then 10 else 5" "10"
  evalEnvTest "if2" "" "if 2 /= 2 then 1 else 0" "0"
  evalEnvTest "if3" "" "if x >= y then 5 * 5 else 6 * 6" "if x >= y then 5 * 5 else 6 * 6"

  evalEnvTest "env1" "x = 10" "x" "10"
  evalEnvTest "env2" "x = 10\ny = 20" "x * y" "200"
  evalEnvTest "env3" "double x = x + x" "double 10" "20"
  evalEnvTest "env4" "double x = x + x" "double (double (double 10))" "80"
  evalEnvTest "env5" "double x = x + x" "double $ double $ double 10" "80"
  evalEnvTest "env6" "double x = x + x" "(double . double . double) 10" "80"
  evalEnvTest "env6" "length (_:xs) = 1 + length xs\nlength [] = 0" "length [1, 2, 3, 4, 5]" "5"

  evalEnvTest "eval_list" "" "[2 + 2, 3 * 3]" "[4, 9]"
  evalEnvTest "eval_tuple" "" "(2+2, 3 * 3)" "(4, 9)"

  -- This test gets stuck in an endless loop,
  -- evalEnvTest "fix" "f x = f x" "f 10" "f 10"

  evalEnvTest "fac" "fac 1 = 1\nfac n = n * fac (n - 1)" "fac 6" "720"
  evalEnvTest "prelude" prelude "sum (map (^2) [1,2,3,4])" "30"

  evalEnvTest "TAE2a"
    ( prelude <> "\n" <>
      "pair (x:y:rs) = (x, y) : pair (y:rs)\n" <>
      "pair _        = []")
    "pair [1, 2, 3, 4]"
    "[(1, 2), (2, 3), (3, 4)]"
  evalEnvTest "TAE2b" prelude "foldr (\\a b -> a + b * 10) 0 [3, 2, 1]" "123"
  evalEnvTest "TAE2c"
    (prelude <> "\nsublist f t ls = drop f (take (t + f) ls)\n")
    "sublist 1 3 [0, 1, 2, 3, 4]"
    "[1, 2, 3]"

  evalEnvTest "TAE3a" prelude "map (>= 2) [1, 2, 3]" "[False, True, True]"
  evalEnvTest "TAE3b" prelude "foldr (\\a b -> b ++ [a]) [] [1, 2, 3]" "[3, 2, 1]"
  evalEnvTest "TAE3c" prelude "take 3 (iterate (3*) 1)" "[1, 3, 9]"
  evalEnvTest "TAE3d" prelude "filter (const True) [1, 3, 5, 7]" "[1, 3, 5, 7]"
  evalEnvTest "TAE3e" prelude "map (length . snd) [(7, \"sieben\"), (1, \"eins\")]" "[6, 4]"
  evalEnvTest "TAE3f" prelude "foldr (:) [3, 4] [1, 2]" "[1, 2, 3, 4]"
  evalEnvTest "TAE3g" prelude "foldl (\\(i, c) s -> (i + 1, c + length s)) (0, 0) [\"a\", \"bc\", \"defg\"]" "(3, 7)"

  evalEnvTest "TAT2a"
    (prelude <> "\nnth ls n = head (drop n ls)\n")
    "nth [0, 1, 2, 3] 2"
    "2"
  evalEnvTest "TAT2b"
    ( prelude <> "\n" <>
      "smallest (x:y:rs) = if x < y then smallest (x:rs) else smallest (y:rs)\n" <>
      "smallest [x]      = x")
    "smallest [5, 3, 7]"
    "3"
  evalEnvTest "TAT2c" prelude "foldl (\\(s, p) i -> (i + s, i * p)) (0, 1) [2, 3, 4]" "(9, 24)"

  evalEnvTest "TAT3a" prelude "map (2^) [1, 2, 3]" "[2, 4, 8]"
  evalEnvTest "TAT3b" prelude "foldl (*) 1 [1, 2, 3, 4]" "24"
  evalEnvTest "TAT3c" prelude "map (== 3) [1, 2, 3, 4]" "[False, False, True, False]"
  evalEnvTest "TAT3d" prelude "filter (/= 's') \"asdf\"" "\"adf\""
  evalEnvTest "TAT3e" prelude "map (fst . head) [[(1, 2)], [(3, 4)]]" "[1, 3]"
  evalEnvTest "TAT3f" prelude "foldl (-) 10 [1, 2, 3]" "4"
  evalEnvTest "TAT3g" prelude "zipWith (\\a b -> map (+a) b) [1, 2] [[3, 4], [5, 6]]" "[[4, 5], [7, 8]]"

  evalEnvTest "string_third1" "thrd (_:(_:(x:_))) = x" "thrd \"1234\"" "'3'"
  evalEnvTest "string_third2" "thrd [_,_,x,_] = x" "thrd \"1234\"" "'3'"

  evalEnvTest "pattern_matching4" "f ( x :  y : z : rs  ) = (x + y + z) * length rs\nlength (_:xs) = 1 + length xs\nlength [] = 0" "f [2, 3, 5, 8, 11]" "20"
  evalEnvTest "pattern_matching5" "f ( [ x ] : [ y , z ] : [ ] ) = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching6" "f [  [ x ] , [ y , z ] ] = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching7" "f [(a:b:c:rs1), (x:y:z:rs2)] = a * x + b * y + c * z" "f [[1, 2, 3], [100, 10, 1]]" "123"

  evalEnvTest "eval_names" "nat = [1, 2, 3, 4, 5]" "nat" "[1, 2, 3, 4, 5]"

  evalEnvTest "infix_functions_1" prelude "3 `take` (2 `drop` [1, 2, 3, 4, 5, 6, 7])" "[3, 4, 5]"
  evalEnvTest "infix_functions_2" prelude "(\\x -> x `mod` 2 == 0) `filter` [1, 2, 3, 4, 5, 6]" "[2, 4, 6]"
  evalEnvTest "infix_functions_3" prelude "(*2) `map` [1, 2, 3]" "[2, 4, 6]"

  evalEnvTest "arithmetic_sequences_1" prelude "sum [1, 3 .. 100]" "2500"
  evalEnvTest "arithmetic_sequences_3" prelude "length [ 7 * 7, 8 * 8 .. 42 * 42]" "115"
  evalEnvTest "arithmetic_sequences_5" prelude "sum $ take 100 [500 ..]" "54950"
  evalEnvTest "arithmetic_sequences_6" prelude "[1, -1 .. 0]" "[1]"
  evalEnvTest "arithmetic_sequences_7" prelude "sum [10, 9 .. -10]" "0"
  evalEnvTest "arithmetic_sequences_8" prelude "[True .. False]" "[]"
  evalEnvTest "arithmetic_sequences_9" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_11" prelude "[False, True ..]" "[False, True]"
  evalEnvTest "arithmetic_sequences_12" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_13" prelude "[1 .. 10]" "[1,2,3,4,5,6,7,8,9,10]"
  evalEnvTest "arithmetic_sequences_14" prelude "[5, 9 .. 20]" "[5, 9, 13, 17]"
  evalEnvTest "arithmetic_sequences_15" prelude "take 5 [3, -1 ..]" "[3, -1, -5, -9, -13]"
  evalEnvTest "arithmetic_sequences_16" prelude "take 11 [-5 ..]" "[-5, -4, -3, -2, -1, 0, 1, 2 ,3, 4, 5]"
  evalEnvTest "arithmetic_sequences_17" prelude "[2147483647 ..]" "[2147483647]"
  evalEnvTest "arithmetic_sequences_18" prelude "[2147483644, 2147483646 ..]" "[2147483644, 2147483646]"
  evalEnvTest "arithmetic_sequences_19" prelude "[-2147483648]" "[-2147483648]"
  evalEnvTest "arithmetic_sequences_20" prelude "[-2147483645, -2147483647 ..]" "[-2147483645, -2147483647]"

  evalEnvTest "list_comprehension_1" prelude "[ x | x <- [1 .. 10], even x]" "[2, 4, 6, 8, 10]"
  evalEnvTest "list_comprehension_2" prelude "[ (x, y) | x <- [1 .. 3], y <- [1 .. 3], x + y == 4]" "[(1,3), (2,2), (3,1)]"
  evalEnvTest "list_comprehension_3" prelude "(\\x -> [ x | let x = 1]) 2"    "[1]"
  evalEnvTest "list_comprehension_4" prelude "[ x | let x = 1, True, let x = 'a']" "['a']"
  evalEnvTest "list_comprehension_5" prelude "[ y | y <- [1 .. 10], y < y]"  "[]"
  evalEnvTest "list_comprehension_6" prelude "[ [ y | y <- reverse x] | x <- [[1 .. 10]]]" "[[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]]"
  evalEnvTest "list_comprehension_7" prelude "[ x | x <- [1 .. 5], y <- [x .. 5]]" "[1,1,1,1,1, 2,2,2,2, 3,3,3, 4,4, 5]"
  evalEnvTest "list_comprehension_8" prelude "[x | x <- \"wer misst zu viele gabeln\", elem x \"itzgw\"]" "\"witzig\""
  evalEnvTest "list_comprehension_9" prelude "[(x, z) | x <- [1 .. 5], z <- [y | y <- [1 .. 5], mod x y == 0] ]" "[(1,1), (2,1), (2,2), (3,1), (3,3), (4,1), (4,2), (4,4), (5,1), (5,5)]"
  evalEnvTest "list_comprehension_10" prelude "[z | let y = [True, True, False], z <- y, z]" "[True, True]"

  --should fail, due to overlapping defs
  --evalEnvTest "let_expression_1" prelude "let x = 1; x = 'c' in x" "'c'"
  evalEnvTest "let_expression_2" prelude "let (x, y) = (\\g -> g, \"Hello\") in x y" "\"Hello\""
  evalEnvTest "let_expression_3" prelude "let x = 1 ; y = x + 1; z = y + 1 in x + y + z" "6"
  evalEnvTest "let_expression_4" prelude "let x = 1 in let y = 2 in x + y" "3"
  --                                                                                should be: "True"
  evalEnvTest "let_expression_5" prelude "(let x = [1,2,3] in x) == (let x = 1; y = 2; z = 3 in [x,y,z])" "[1,2,3] == [1,2,3]"
  evalEnvTest "let_expression_6" prelude "let sum = \\x -> x ; y = sum [1,2,3] in y" "[1,2,3]"

  testsADT

testsADT :: Test Unit
testsADT = do
{-
  eval1test "constr-1"
    "1 :+ 1"
    "1 :+ 1"
  eval1test "constr-2"
    "Foo"
    "Foo"
  eval1test "constr-3"
    "Foo 1"
    "Foo 1"
  eval1test "constr-4"
    "Foo 1 2"
    "Foo 1 2"
-}
  eval1test "constr-5"
    "if True then Foo else Bar"
    "Foo"

  eval1test "constr-6"
    "if False then Foo else Bar"
    "Bar"

  eval1EnvTest "func-1"
    "foo (Foo x) = x"
    "foo (Foo 1)"
    "1"

  eval1EnvTest "func-2"
    "foo (Foo x y) = x + y"
    "foo (Foo 1 2)"
    "1 + 2"

  eval1EnvTest "map-func-3"
    "map f Nil = Nil\nmap f (Cons x xs) = Cons (f x) (map f xs)"
    "map (1 +) (Cons 1 (Cons 2 (Cons 3 Nil)))"
    "Cons ((1 +) 1) (map (1 +) (Cons 2 (Cons 3 Nil)))"

  eval1EnvTest "map-func-4"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) Nil"
    "Nil"

  eval1EnvTest "map-func-5"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) (1 :: (2 :: (3 :: Nil)))"
    "(^2) 1 :: map (^2) (2 :: (3 :: Nil))"

  eval1EnvTest "tuple-1"
    "fst (Tuple a _) = a\n"
    "fst (Tuple (Tuple 1 2) 3)"
    "Tuple 1 2"

  eval1EnvTest "tuple-2"
    "snd (Tuple _ a) = a\n"
    "snd (Tuple (Tuple 1 2) 3)"
    "3"

  eval1EnvTest "infix-1"
    "fst (a ::: _) = a"
    "fst (1 ::: 3)"
    "1"

  eval1EnvTest "infix-2"
    "snd (_ ::: a) = a"
    "snd (1 ::: 3)"
    "3"

  evalEnvTest "infix-3"
    "map f g (a :-: b) = f a :-: g b\ndouble = map (*2) (*2)"
    "double (2 :-: 3)"
    "4 :-: 6"

  evalEnvTest "prefix-1"
    "map f g (Tuple x y) = Tuple (f x) (g y)\ndouble = map (*2) (*2)"
    "double (Tuple 2 3)"
    "Tuple 4 6"

  evalEnvTest "constr-nested-1"
    "foo (Bar (Bar a) Foo) = Foo a a"
    "foo (Bar (Bar Foo) Foo)"
    "Foo Foo Foo"

  evalEnvTest "pdp1-a" envPdP1
    ("numParts " <> bspPdP1)
    "13"

  evalEnvTest "pdp1-b" envPdP1
    ("foldBauwerk Rechteck Spitze Split " <> bspPdP1)
    bspPdP1

  evalEnvTest "pdp1-c" envPdP1
    ("maxHoehe " <> bspPdP1)
    "87"

  evalEnvTest "pdp1-d" envPdP1
    ("numPeaks " <> bspPdP1)
    "5"

  evalEnvTest "pdp1-e" envPdP1
    ("wellformed " <> bspPdP1)
    "True"

  evalEnvTest "fp-a" envPdP2
    ("foldMixTree QuadSplit Split Color " <> bspPdP2)
    bspPdP2

  evalEnvTest "fp-b" envPdP2
    ("areas " <> bspPdP2)
    "22"

  evalEnvTest "fp-c" envPdP2
    ("wellformedTree " <> bspPdP2)
    "True"

  evalEnvTest "rose-fold" envRoseFold
    ("foldRoseTree Node Leaf " <> bspRoseFold)
    bspRoseFold

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree)
    bspBinTree

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils " <> bspBinTree)
    "6"

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree2)
    bspBinTree2

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils (" <> bspBinTree2 <> ")")
    "2"

envRoseFold :: String
envRoseFold = """
map _ [] = []
map f (x:xs) = f x : map f xs

foldRoseTree fN fL (Leaf a) = fL a
foldRoseTree fN fL (Node ts) = fN (map (foldRoseTree fN fL) ts)
"""

bspRoseFold :: String
bspRoseFold = """(Node
  [ Leaf 1
  , Leaf 2
  , Leaf 3
  , Node
    [ Leaf 4
    , Leaf 5
    , Leaf 6 ]])
"""

envBinTree :: String
envBinTree = """
foldBinTree fNil fNode Nil = fNil
foldBinTree fNil fNode (l ::: r) = fNode
  (foldBinTree fNil fNode l)
  (foldBinTree fNil fNode r)

nils = foldBinTree 1 (+)
"""

bspBinTree :: String
bspBinTree = "(((Nil ::: Nil) ::: Nil) ::: (Nil ::: (Nil ::: Nil)))"

bspBinTree2 :: String
bspBinTree2 = "Nil ::: Nil"

envPdP1 :: String
envPdP1 = """
foldBauwerk fRechteck fSpitze fSplit (Rechteck br ho bw)
  = fRechteck br ho (foldBauwerk fRechteck fSpitze fSplit bw)
foldBauwerk fRechteck fSpitze fSplit (Spitze br ho)
  = fSpitze br ho
foldBauwerk fRechteck fSpitze fSplit (Split l r)
  = fSplit (foldBauwerk fRechteck fSpitze fSplit l) (foldBauwerk fRechteck fSpitze fSplit r)

numParts (Rechteck _ _ bw) = 1 + numParts bw
numParts (Spitze _ _) = 1
numParts (Split l r)  = numParts l + numParts r

max a b = if a < b then b else a

maxHoehe = foldBauwerk
  (\_ ho hor -> ho + hor)
  (\_ h -> h)
  max

numPeaks = foldBauwerk (\_ _ ps -> ps) (\_ _ -> 1) (+)

wellformed
  = (> 0)
  . foldBauwerk
    (\br _ br' -> if br' < 0 || br' > br then -1 else br)
    (\br _ -> br)
    (\l r -> l + r)
"""

bspPdP1 :: String
bspPdP1 = """(Rechteck 50 20
  (Split
    (Rechteck 20 15
      (Split
        (Rechteck 10 20
          (Rechteck 8 18
            (Spitze 8 14)))
        (Rechteck 8 17
          (Spitze 8 14))))
    (Rechteck 20 15
      (Split
        (Rechteck 8 17
          (Spitze 8 14))
        (Rechteck 10 20
          (Split
            (Spitze 5 17)
            (Spitze 5 17)))))))
"""

envPdP2 :: String
envPdP2 = """
foldMixTree fQ fS fC (QuadSplit ro ru lu lo) = fQ
  (foldMixTree fQ fS fC ro)
  (foldMixTree fQ fS fC ru)
  (foldMixTree fQ fS fC lu)
  (foldMixTree fQ fS fC lo)
foldMixTree fQ fS fC (Split a ts)
  = fS a (map (\(d, t) -> (d, foldMixTree fQ fS fC t)) ts)
foldMixTree fQ fS fC (Color c) = fC c

wellformed xs = all (\(x,_) -> x > 0) xs && (10 == sum (map fst xs))

all _ [] = True
all p (x:xs) = if p x then all p xs else False

sum [] = 0
sum (x:xs) = x + sum xs

map f [] = []
map f (x:xs) = f x : map f xs

fst (x,_) = x
snd (_,x) = x

areas = foldMixTree
  (\ro ru lu lo -> ro + ru + lu + lo)
  (\_ -> sum . map snd)
  (\_ -> 1)

wellformedTree = foldMixTree
  (\ro ru lu lo -> ro && ru && lu && lo)
  (\_ -> wellformed)
  (\_ -> True)
"""

bspPdP2 :: String
bspPdP2 = """(Split H
  [ (2, Color White)
  , (2, Split V
      [ (3, Color White)
      , (2, QuadSplit
          (Color White)
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey))
      , (2, Split H
          [ (5, Color White)
          , (5, Color LightGrey)])
      , (3, Color White)])
  , (1, Split V
      [ (4, Color Black)
      , (4, Color LightGrey)
      , (2, Color White) ])
  , (2, Split V
      [ (2, Color White)
      , (2, QuadSplit
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey)
          (Color White))
      , (1, Color White)
      , (2, Split H
          [ (5, Color LightGrey)
          , (5, Color White) ])
      , (3, Color White)])
  , (3, Color White)])
"""

module Test.Evaluator where

import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
-- import Data.List (List, singleton)

-- import Control.Monad.Writer (Writer, tell)

import Parser (definitions, expression, runParserIndent)
import Evaluator (eval, eval1, runEvalM, defsToEnv)
import Test.Parser (prelude)

import Test.Utils (Test, tell, padLeft)

tell' :: String -> Test Unit
tell' = tell

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right inExp) (Right expExp)) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" ++ name ++ ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

eval1EnvTest :: String -> String -> String -> String -> Test Unit
eval1EnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" <> name <> ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

evalEnvTest :: String -> String -> String -> String -> Test Unit
evalEnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp == expExp
        then pure unit -- log $ "Eval success (" ++ name ++ ")"
        else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input String:\n"
            <> padLeft input <> "\n"
            <> "Input Parsed:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show evalExp) <> "\n"
            <> "Expected String:\n"
            <> padLeft expected <> "\n"
            <> "Expected Parsed:\n"
            <> padLeft (show expExp) <> "\n"
            <> "Definitions String:\n"
            <> padLeft env <> "\n"
            <> "Definitions Parsed:\n"
            <> padLeft (show defs)
  (Tuple (Tuple pi pe) pd) -> tell'
     $ "Parse fail (" <> name <> "):\n"
    <> "Input:\n"
    <> padLeft (show pi) <> "\n"
    <> "Expected:\n"
    <> padLeft (show pe) <> "\n"
    <> "Definitions:\n"
    <> padLeft (show pd)

runTests :: Test Unit
runTests = do
  eval1test "add" "1+1" "2"
  eval1test "power" "2^10" "1024"
  eval1test "append" "[1] ++ [2]" "[1, 2]"
  eval1test "cons" "True:[]" "[True]"
  eval1test "lambda" "(\\a b -> a + b) 1 2" "1 + 2"
  eval1test "section1" "(*5) 7" "7 * 5"
  eval1test "section2" "(10<) 8" "10 < 8"
  eval1test "prefix" "(&&) True True" "True && True"
  eval1test "if_then_else" "if True then 42 else 0" "42"
  eval1test "pattern_matching1" "(\\(x:xs) -> x) [1, 2, 3]" "1"
  eval1test "pattern_matching2" "(\\[a, b, c] -> c) [1, 2, 3]" "3"
  eval1test "pattern_matching3" "(\\(a, b) (c, d, e) -> d) (1, 2) (3, 2*2, 5)" "2*2"
  eval1test "lambda2" "(\\x y -> [0, x, y, x + y]) 1 2" "[0, 1, 2, 1 + 2]"
  eval1test "string1" "\"as\" ++ \"df\"" "\"asdf\""
  eval1test "string2" "'a' : \"sdf\"" "\"asdf\""

  eval1EnvTest "double_func" "double x = x + x" "double 10" "10 + 10"
  eval1EnvTest "map_func1" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) []" "[]"
  eval1EnvTest "map_func2" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) [1, 2, 3]" "(^2) 1 : map (^2) [2, 3]"

  evalEnvTest "evalAll1" "" "1 + 2 + 3" "6"
  evalEnvTest "evalAll2" "" "(2^10) > (10^2)" "True"
  evalEnvTest "evalAll3" "" "3" "3"
  evalEnvTest "evalAll4" "" "x + y" "x + y"
  evalEnvTest "evalAll5" "" "(2 * 5) * x + 2 ^ 3" "10 * x + 8"
  evalEnvTest "evalAll6" "" "1 / 0" "1 / 0"

  evalEnvTest "evalNegNumber1" "" "(-3) - (-4)" "1"
  evalEnvTest "evalNegNumber2" "" "(-2) * (-2)" "4"
  evalEnvTest "evalNegNumber3" "" "-(-(5*5) + 6*6) + 7*7" (show (-(-(5*5) + 6*6) + 7*7)) -- 38
  evalEnvTest "evalNegNumber4" "" "-3 * 7 + 23" "2"

  evalEnvTest "if1" "" "if 10 > 5 then 10 else 5" "10"
  evalEnvTest "if2" "" "if 2 /= 2 then 1 else 0" "0"
  evalEnvTest "if3" "" "if x >= y then 5 * 5 else 6 * 6" "if x >= y then 5 * 5 else 6 * 6"

  evalEnvTest "env1" "x = 10" "x" "10"
  evalEnvTest "env2" "x = 10\ny = 20" "x * y" "200"
  evalEnvTest "env3" "double x = x + x" "double 10" "20"
  evalEnvTest "env4" "double x = x + x" "double (double (double 10))" "80"
  evalEnvTest "env5" "double x = x + x" "double $ double $ double 10" "80"
  evalEnvTest "env6" "double x = x + x" "(double . double . double) 10" "80"
  evalEnvTest "env6" "length (_:xs) = 1 + length xs\nlength [] = 0" "length [1, 2, 3, 4, 5]" "5"

  evalEnvTest "eval_list" "" "[2 + 2, 3 * 3]" "[4, 9]"
  evalEnvTest "eval_tuple" "" "(2+2, 3 * 3)" "(4, 9)"

  -- This test gets stuck in an endless loop,
  -- evalEnvTest "fix" "f x = f x" "f 10" "f 10"

  evalEnvTest "fac" "fac 1 = 1\nfac n = n * fac (n - 1)" "fac 6" "720"
  evalEnvTest "prelude" prelude "sum (map (^2) [1,2,3,4])" "30"

  evalEnvTest "TAE2a"
    ( prelude <> "\n" <>
      "pair (x:y:rs) = (x, y) : pair (y:rs)\n" <>
      "pair _        = []")
    "pair [1, 2, 3, 4]"
    "[(1, 2), (2, 3), (3, 4)]"
  evalEnvTest "TAE2b" prelude "foldr (\\a b -> a + b * 10) 0 [3, 2, 1]" "123"
  evalEnvTest "TAE2c"
    (prelude <> "\nsublist f t ls = drop f (take (t + f) ls)\n")
    "sublist 1 3 [0, 1, 2, 3, 4]"
    "[1, 2, 3]"

  evalEnvTest "TAE3a" prelude "map (>= 2) [1, 2, 3]" "[False, True, True]"
  evalEnvTest "TAE3b" prelude "foldr (\\a b -> b ++ [a]) [] [1, 2, 3]" "[3, 2, 1]"
  evalEnvTest "TAE3c" prelude "take 3 (iterate (3*) 1)" "[1, 3, 9]"
  evalEnvTest "TAE3d" prelude "filter (const True) [1, 3, 5, 7]" "[1, 3, 5, 7]"
  evalEnvTest "TAE3e" prelude "map (length . snd) [(7, \"sieben\"), (1, \"eins\")]" "[6, 4]"
  evalEnvTest "TAE3f" prelude "foldr (:) [3, 4] [1, 2]" "[1, 2, 3, 4]"
  evalEnvTest "TAE3g" prelude "foldl (\\(i, c) s -> (i + 1, c + length s)) (0, 0) [\"a\", \"bc\", \"defg\"]" "(3, 7)"

  evalEnvTest "TAT2a"
    (prelude <> "\nnth ls n = head (drop n ls)\n")
    "nth [0, 1, 2, 3] 2"
    "2"
  evalEnvTest "TAT2b"
    ( prelude <> "\n" <>
      "smallest (x:y:rs) = if x < y then smallest (x:rs) else smallest (y:rs)\n" <>
      "smallest [x]      = x")
    "smallest [5, 3, 7]"
    "3"
  evalEnvTest "TAT2c" prelude "foldl (\\(s, p) i -> (i + s, i * p)) (0, 1) [2, 3, 4]" "(9, 24)"

  evalEnvTest "TAT3a" prelude "map (2^) [1, 2, 3]" "[2, 4, 8]"
  evalEnvTest "TAT3b" prelude "foldl (*) 1 [1, 2, 3, 4]" "24"
  evalEnvTest "TAT3c" prelude "map (== 3) [1, 2, 3, 4]" "[False, False, True, False]"
  evalEnvTest "TAT3d" prelude "filter (/= 's') \"asdf\"" "\"adf\""
  evalEnvTest "TAT3e" prelude "map (fst . head) [[(1, 2)], [(3, 4)]]" "[1, 3]"
  evalEnvTest "TAT3f" prelude "foldl (-) 10 [1, 2, 3]" "4"
  evalEnvTest "TAT3g" prelude "zipWith (\\a b -> map (+a) b) [1, 2] [[3, 4], [5, 6]]" "[[4, 5], [7, 8]]"

  evalEnvTest "string_third1" "thrd (_:(_:(x:_))) = x" "thrd \"1234\"" "'3'"
  evalEnvTest "string_third2" "thrd [_,_,x,_] = x" "thrd \"1234\"" "'3'"

  evalEnvTest "pattern_matching4" "f ( x :  y : z : rs  ) = (x + y + z) * length rs\nlength (_:xs) = 1 + length xs\nlength [] = 0" "f [2, 3, 5, 8, 11]" "20"
  evalEnvTest "pattern_matching5" "f ( [ x ] : [ y , z ] : [ ] ) = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching6" "f [  [ x ] , [ y , z ] ] = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching7" "f [(a:b:c:rs1), (x:y:z:rs2)] = a * x + b * y + c * z" "f [[1, 2, 3], [100, 10, 1]]" "123"

  evalEnvTest "eval_names" "nat = [1, 2, 3, 4, 5]" "nat" "[1, 2, 3, 4, 5]"

  evalEnvTest "infix_functions_1" prelude "3 `take` (2 `drop` [1, 2, 3, 4, 5, 6, 7])" "[3, 4, 5]"
  evalEnvTest "infix_functions_2" prelude "(\\x -> x `mod` 2 == 0) `filter` [1, 2, 3, 4, 5, 6]" "[2, 4, 6]"
  evalEnvTest "infix_functions_3" prelude "(*2) `map` [1, 2, 3]" "[2, 4, 6]"

  evalEnvTest "arithmetic_sequences_1" prelude "sum [1, 3 .. 100]" "2500"
  evalEnvTest "arithmetic_sequences_3" prelude "length [ 7 * 7, 8 * 8 .. 42 * 42]" "115"
  evalEnvTest "arithmetic_sequences_5" prelude "sum $ take 100 [500 ..]" "54950"
  evalEnvTest "arithmetic_sequences_6" prelude "[1, -1 .. 0]" "[1]"
  evalEnvTest "arithmetic_sequences_7" prelude "sum [10, 9 .. -10]" "0"
  evalEnvTest "arithmetic_sequences_8" prelude "[True .. False]" "[]"
  evalEnvTest "arithmetic_sequences_9" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_11" prelude "[False, True ..]" "[False, True]"
  evalEnvTest "arithmetic_sequences_12" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_13" prelude "[1 .. 10]" "[1,2,3,4,5,6,7,8,9,10]"
  evalEnvTest "arithmetic_sequences_14" prelude "[5, 9 .. 20]" "[5, 9, 13, 17]"
  evalEnvTest "arithmetic_sequences_15" prelude "take 5 [3, -1 ..]" "[3, -1, -5, -9, -13]"
  evalEnvTest "arithmetic_sequences_16" prelude "take 11 [-5 ..]" "[-5, -4, -3, -2, -1, 0, 1, 2 ,3, 4, 5]"
  evalEnvTest "arithmetic_sequences_17" prelude "[2147483647 ..]" "[2147483647]"
  evalEnvTest "arithmetic_sequences_18" prelude "[2147483644, 2147483646 ..]" "[2147483644, 2147483646]"
  evalEnvTest "arithmetic_sequences_19" prelude "[-2147483648]" "[-2147483648]"
  evalEnvTest "arithmetic_sequences_20" prelude "[-2147483645, -2147483647 ..]" "[-2147483645, -2147483647]"

  evalEnvTest "list_comprehension_1" prelude "[ x | x <- [1 .. 10], even x]" "[2, 4, 6, 8, 10]"
  evalEnvTest "list_comprehension_2" prelude "[ (x, y) | x <- [1 .. 3], y <- [1 .. 3], x + y == 4]" "[(1,3), (2,2), (3,1)]"
  evalEnvTest "list_comprehension_3" prelude "(\\x -> [ x | let x = 1]) 2"    "[1]"
  evalEnvTest "list_comprehension_4" prelude "[ x | let x = 1, True, let x = 'a']" "['a']"
  evalEnvTest "list_comprehension_5" prelude "[ y | y <- [1 .. 10], y < y]"  "[]"
  evalEnvTest "list_comprehension_6" prelude "[ [ y | y <- reverse x] | x <- [[1 .. 10]]]" "[[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]]"
  evalEnvTest "list_comprehension_7" prelude "[ x | x <- [1 .. 5], y <- [x .. 5]]" "[1,1,1,1,1, 2,2,2,2, 3,3,3, 4,4, 5]"
  evalEnvTest "list_comprehension_8" prelude "[x | x <- \"wer misst zu viele gabeln\", elem x \"itzgw\"]" "\"witzig\""
  evalEnvTest "list_comprehension_9" prelude "[(x, z) | x <- [1 .. 5], z <- [y | y <- [1 .. 5], mod x y == 0] ]" "[(1,1), (2,1), (2,2), (3,1), (3,3), (4,1), (4,2), (4,4), (5,1), (5,5)]"
  evalEnvTest "list_comprehension_10" prelude "[z | let y = [True, True, False], z <- y, z]" "[True, True]"

  --should fail, due to overlapping defs
  --evalEnvTest "let_expression_1" prelude "let x = 1; x = 'c' in x" "'c'"
  evalEnvTest "let_expression_2" prelude "let (x, y) = (\\g -> g, \"Hello\") in x y" "\"Hello\""
  evalEnvTest "let_expression_3" prelude "let x = 1 ; y = x + 1; z = y + 1 in x + y + z" "6"
  evalEnvTest "let_expression_4" prelude "let x = 1 in let y = 2 in x + y" "3"
  --                                                                                should be: "True"
  evalEnvTest "let_expression_5" prelude "(let x = [1,2,3] in x) == (let x = 1; y = 2; z = 3 in [x,y,z])" "[1,2,3] == [1,2,3]"
  evalEnvTest "let_expression_6" prelude "let sum = \\x -> x ; y = sum [1,2,3] in y" "[1,2,3]"

  testsADT

testsADT :: Test Unit
testsADT = do
  eval1test "constr-1"
    "1 :+ 1"
    "1 :+ 1"
{-
  eval1test "constr-2"
    "Foo"
    "Foo"
  eval1test "constr-3"
    "Foo 1"
    "Foo 1"
  eval1test "constr-4"
    "Foo 1 2"
    "Foo 1 2"
-}
  eval1test "constr-5"
    "if True then Foo else Bar"
    "Foo"

  eval1test "constr-6"
    "if False then Foo else Bar"
    "Bar"

  eval1EnvTest "func-1"
    "foo (Foo x) = x"
    "foo (Foo 1)"
    "1"

  eval1EnvTest "func-2"
    "foo (Foo x y) = x + y"
    "foo (Foo 1 2)"
    "1 + 2"

  eval1EnvTest "map-func-3"
    "map f Nil = Nil\nmap f (Cons x xs) = Cons (f x) (map f xs)"
    "map (1 +) (Cons 1 (Cons 2 (Cons 3 Nil)))"
    "Cons ((1 +) 1) (map (1 +) (Cons 2 (Cons 3 Nil)))"

  eval1EnvTest "map-func-4"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) Nil"
    "Nil"

  eval1EnvTest "map-func-5"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) (1 :: (2 :: (3 :: Nil)))"
    "(^2) 1 :: map (^2) (2 :: (3 :: Nil))"

  eval1EnvTest "tuple-1"
    "fst (Tuple a _) = a\n"
    "fst (Tuple (Tuple 1 2) 3)"
    "Tuple 1 2"

  eval1EnvTest "tuple-2"
    "snd (Tuple _ a) = a\n"
    "snd (Tuple (Tuple 1 2) 3)"
    "3"

  eval1EnvTest "infix-1"
    "fst (a ::: _) = a"
    "fst (1 ::: 3)"
    "1"

  eval1EnvTest "infix-2"
    "snd (_ ::: a) = a"
    "snd (1 ::: 3)"
    "3"

  evalEnvTest "infix-3"
    "map f g (a :-: b) = f a :-: g b\ndouble = map (*2) (*2)"
    "double (2 :-: 3)"
    "4 :-: 6"

  evalEnvTest "prefix-1"
    "map f g (Tuple x y) = Tuple (f x) (g y)\ndouble = map (*2) (*2)"
    "double (Tuple 2 3)"
    "Tuple 4 6"

  evalEnvTest "constr-nested-1"
    "foo (Bar (Bar a) Foo) = Foo a a"
    "foo (Bar (Bar Foo) Foo)"
    "Foo Foo Foo"

  evalEnvTest "pdp1-a" envPdP1
    ("numParts " <> bspPdP1)
    "13"

  evalEnvTest "pdp1-b" envPdP1
    ("foldBauwerk Rechteck Spitze Split " <> bspPdP1)
    bspPdP1

  evalEnvTest "pdp1-c" envPdP1
    ("maxHoehe " <> bspPdP1)
    "87"

  evalEnvTest "pdp1-d" envPdP1
    ("numPeaks " <> bspPdP1)
    "5"

  evalEnvTest "pdp1-e" envPdP1
    ("wellformed " <> bspPdP1)
    "True"

  evalEnvTest "fp-a" envPdP2
    ("foldMixTree QuadSplit Split Color " <> bspPdP2)
    bspPdP2

  evalEnvTest "fp-b" envPdP2
    ("areas " <> bspPdP2)
    "22"

  evalEnvTest "fp-c" envPdP2
    ("wellformedTree " <> bspPdP2)
    "True"

  evalEnvTest "rose-fold" envRoseFold
    ("foldRoseTree Node Leaf " <> bspRoseFold)
    bspRoseFold

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree)
    bspBinTree

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils " <> bspBinTree)
    "6"

  evalEnvTest "bin-tree-fold-1" envBinTree
    ("foldBinTree Nil (:::) " <> bspBinTree2)
    bspBinTree2

  evalEnvTest "bin-tree-fold-2" envBinTree
    ("nils (" <> bspBinTree2 <> ")")
    "2"

envRoseFold :: String
envRoseFold = """
map _ [] = []
map f (x:xs) = f x : map f xs

foldRoseTree fN fL (Leaf a) = fL a
foldRoseTree fN fL (Node ts) = fN (map (foldRoseTree fN fL) ts)
"""

bspRoseFold :: String
bspRoseFold = """(Node
  [ Leaf 1
  , Leaf 2
  , Leaf 3
  , Node
    [ Leaf 4
    , Leaf 5
    , Leaf 6 ]])
"""

envBinTree :: String
envBinTree = """
foldBinTree fNil fNode Nil = fNil
foldBinTree fNil fNode (l ::: r) = fNode
  (foldBinTree fNil fNode l)
  (foldBinTree fNil fNode r)

nils = foldBinTree 1 (+)
"""

bspBinTree :: String
bspBinTree = "(((Nil ::: Nil) ::: Nil) ::: (Nil ::: (Nil ::: Nil)))"

bspBinTree2 :: String
bspBinTree2 = "Nil ::: Nil"

envPdP1 :: String
envPdP1 = """
foldBauwerk fRechteck fSpitze fSplit (Rechteck br ho bw)
  = fRechteck br ho (foldBauwerk fRechteck fSpitze fSplit bw)
foldBauwerk fRechteck fSpitze fSplit (Spitze br ho)
  = fSpitze br ho
foldBauwerk fRechteck fSpitze fSplit (Split l r)
  = fSplit (foldBauwerk fRechteck fSpitze fSplit l) (foldBauwerk fRechteck fSpitze fSplit r)

numParts (Rechteck _ _ bw) = 1 + numParts bw
numParts (Spitze _ _) = 1
numParts (Split l r)  = numParts l + numParts r

max a b = if a < b then b else a

maxHoehe = foldBauwerk
  (\_ ho hor -> ho + hor)
  (\_ h -> h)
  max

numPeaks = foldBauwerk (\_ _ ps -> ps) (\_ _ -> 1) (+)

wellformed
  = (> 0)
  . foldBauwerk
    (\br _ br' -> if br' < 0 || br' > br then -1 else br)
    (\br _ -> br)
    (\l r -> l + r)
"""

bspPdP1 :: String
bspPdP1 = """(Rechteck 50 20
  (Split
    (Rechteck 20 15
      (Split
        (Rechteck 10 20
          (Rechteck 8 18
            (Spitze 8 14)))
        (Rechteck 8 17
          (Spitze 8 14))))
    (Rechteck 20 15
      (Split
        (Rechteck 8 17
          (Spitze 8 14))
        (Rechteck 10 20
          (Split
            (Spitze 5 17)
            (Spitze 5 17)))))))
"""

envPdP2 :: String
envPdP2 = """
foldMixTree fQ fS fC (QuadSplit ro ru lu lo) = fQ
  (foldMixTree fQ fS fC ro)
  (foldMixTree fQ fS fC ru)
  (foldMixTree fQ fS fC lu)
  (foldMixTree fQ fS fC lo)
foldMixTree fQ fS fC (Split a ts)
  = fS a (map (\(d, t) -> (d, foldMixTree fQ fS fC t)) ts)
foldMixTree fQ fS fC (Color c) = fC c

wellformed xs = all (\(x,_) -> x > 0) xs && (10 == sum (map fst xs))

all _ [] = True
all p (x:xs) = if p x then all p xs else False

sum [] = 0
sum (x:xs) = x + sum xs

map f [] = []
map f (x:xs) = f x : map f xs

fst (x,_) = x
snd (_,x) = x

areas = foldMixTree
  (\ro ru lu lo -> ro + ru + lu + lo)
  (\_ -> sum . map snd)
  (\_ -> 1)

wellformedTree = foldMixTree
  (\ro ru lu lo -> ro && ru && lu && lo)
  (\_ -> wellformed)
  (\_ -> True)
"""

bspPdP2 :: String
bspPdP2 = """(Split H
  [ (2, Color White)
  , (2, Split V
      [ (3, Color White)
      , (2, QuadSplit
          (Color White)
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey))
      , (2, Split H
          [ (5, Color White)
          , (5, Color LightGrey)])
      , (3, Color White)])
  , (1, Split V
      [ (4, Color Black)
      , (4, Color LightGrey)
      , (2, Color White) ])
  , (2, Split V
      [ (2, Color White)
      , (2, QuadSplit
          (Color DarkGrey)
          (Color White)
          (Color DarkGrey)
          (Color White))
      , (1, Color White)
      , (2, Split H
          [ (5, Color LightGrey)
          , (5, Color White) ])
      , (3, Color White)])
  , (3, Color White)])
"""


Call setLocalDescription with our offer

Call setLocalDescription with our offer

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Gonimo.UI.Socket.Message as Message
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Lens ((.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(OnAddStream, OnIceCandidate), Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, encodeToString, decodeFromString, Message)
import Gonimo.UI.Socket.Types (BabyStation)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (setLocalDescription, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: (Action -> Eff () Unit) -> Maybe BabyStation -> IO State
init sendAction' babyStation = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "stun:stun.l.google.com:19302"} ] })
  liftEff $ onaddstream (coerceEffects <<< sendAction' <<< OnAddStream ) rtcConnection
  liftEff $ onicecandidate (coerceEffects <<< sendAction' <<< OnIceCandidate ) rtcConnection
  let sockStream = _.mediaStream <$> babyStation
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ sockStream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , rtcConnection : rtcConnection
          , isBabyStation : isJust babyStation
          }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> noEffects
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> noEffects -- handleOnAddStream iceEvent
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescription offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  state <- get
  pure [ liftEff $ do
           addIceCandidate candidate state.rtcConnection
           pure Nop
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask :: Component (Props ps) State (Props ps)
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescription description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               liftEff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      ((maybe Nop AcceptMessage) <<< (decodeFromString =<< _))
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Gonimo.UI.Socket.Message as Message
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Lens ((.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(OnAddStream, OnIceCandidate), Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, encodeToString, decodeFromString, Message)
import Gonimo.UI.Socket.Types (BabyStation)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: (Action -> Eff () Unit) -> Maybe BabyStation -> IO State
init sendAction' babyStation = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "stun:stun.l.google.com:19302"} ] })
  liftEff $ onaddstream (coerceEffects <<< sendAction' <<< OnAddStream ) rtcConnection
  liftEff $ onicecandidate (coerceEffects <<< sendAction' <<< OnIceCandidate ) rtcConnection
  let sockStream = _.mediaStream <$> babyStation
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ sockStream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , rtcConnection : rtcConnection
          , isBabyStation : isJust babyStation
          }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> noEffects
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> noEffects -- handleOnAddStream iceEvent
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            sendMessage $ Message.SessionDescription offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  state <- get
  pure [ liftEff $ do
           addIceCandidate candidate state.rtcConnection
           pure Nop
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask :: Component (Props ps) State (Props ps)
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescription description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               liftEff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      ((maybe Nop AcceptMessage) <<< (decodeFromString =<< _))
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


Fix typo

Fix typo

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List ((:))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | TripleDot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen      = "("
prettyPrintToken RParen      = ")"
prettyPrintToken LSquare     = "["
prettyPrintToken RSquare     = "]"
prettyPrintToken Dash        = "-"
prettyPrintToken TripleDot   = "..."
prettyPrintToken (Name name) = name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.string "..." *> pure TripleDot
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = lower <|> P.oneOf ['_']

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '\'']

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List ((:))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | TripleDot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen      = "("
prettyPrintToken RParen      = ")"
prettyPrintToken LSquare     = "["
prettyPrintToken RSquare     = "]"
prettyPrintToken Dash        = "-"
prettyPrintToken TripleDot   = "..."
prettyPrintToken (Name name) = name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.string "..." *> pure RSquare
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = lower <|> P.oneOf ['_']

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '\'']


[fe] should delete localstorage when no language is selected

module Talk.App
  ( app
  ) where

import Core.Prelude
import Talk.Types

import Component.Header as Header
import Component.Footer as Footer
import Core.Api as Api
import Core.Model (Talk)
import Data.Array as Array
import Data.MediaType (MediaType(..))
import Data.String as String
import Effect.Aff.Class (class MonadAff)
import Foreign.Object as FO
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Simple.JSON (read, readJSON, writeJSON)
import Talk.Sidebar as Sidebar
import Talk.Util as Util
import Web.HTML (window)
import Web.HTML.Window as Window
import Web.Storage.Storage as Storage

type PageData =
  { talk :: Talk
  }

initialState :: PageData -> State
initialState pageData =
  { talk: pageData.talk
  , selectedLang: NoLang
  , transcripts: FO.empty
  , playing: false
  }

renderTalkInfo :: State -> HTML
renderTalkInfo { talk, selectedLang, playing } =
  HH.div_ $ join
  [ pure $ HH.h1 [ class_ "text-lg mb-3"]
    [ HH.text talk.name ]
  , guard (not playing) $> HH.div [ class_ "flex flex-col lg:flex-row"]
    [ HH.div
      [ class_ "flex-no-shrink cursor-pointer bg-cover bg-center Image"
      , style $ "background-image: url(" <> talk.image <> ")"
      , HE.onClick $ HE.input_ OnClickPlay
      ]
      [ HH.div
        [ class_ "h-full text-white hover:bg-grey300 flex items-center justify-center"]
        [ HH.button
          [ class_ "w-8 h-8 text-white text-3xl PlayButton"
          ]
          [ HH.text "▶" ]
        ]
      ]
    , HH.p [ class_ "mt-2 lg:mt-0 lg:ml-3 leading-normal text-grey500"]
      [ HH.text talk.description ]
    ]
  , guard playing $>
    HH.video
    [ class_ "w-full"
    , HP.controls true
    , HP.autoplay true
    ]
    [ HH.source
      [ HP.type_ $ MediaType "video/mp4"
      , HP.src $ Util.mkVideoUrl talk "950k" ]
    , HH.track
      [ HP.src $ Util.mkTranscriptUrl talk selectedLang "vtt"
      , HP.attr (HH.AttrName "kind") "captions"
      , HP.attr (HH.AttrName "default") ""
      ]
    ]
  ]

renderOneTranscript :: State -> String -> HTML
renderOneTranscript state lang =
  case FO.lookup lang state.transcripts of
    Nothing -> HH.text ""
    Just transcript -> HH.div_ $
      transcript <#> \paragraph ->
        HH.p_
        [ HH.text paragraph]

renderTwoTranscripts :: State -> String -> String -> HTML
renderTwoTranscripts state@{ transcripts } lang1 lang2 =
  case FO.lookup lang1 transcripts, FO.lookup lang2 transcripts of
    Nothing, Nothing -> HH.text ""
    Just _, Nothing -> renderOneTranscript state lang1
    Nothing, Just _ -> renderOneTranscript state lang2
    Just transcript1, Just transcript2 -> HH.div_ $
      Array.zip transcript1 transcript2 <#> \(Tuple p1 p2) ->
        HH.div
        [ class_ "Row pb-4 lg:pb-0" ]
        [ HH.p_
          [ HH.text p1]
        , HH.p_
          [ HH.text p2]
        ]

renderTranscript :: State -> HTML
renderTranscript state =
  HH.article
  [ class_ "mt-6 leading-normal"]
  [ case state.selectedLang of
      NoLang ->
        HH.div
        [ class_ "text-center text-lg mt-8 italic"]
        [ HH.text "Select language from sidebar." ]
      OneLang lang ->
        renderOneTranscript state lang
      TwoLang lang1 lang2 ->
        renderTwoTranscripts state lang1 lang2
  ]

render :: State -> HTML
render state =
  HH.div_
  [ Header.render
  , HH.div
    [ class_ "TalkApp container py-6 px-4 xl:px-0"]
    [ HH.div_
      [ renderTalkInfo state
      , renderTranscript state
      ]
    , Sidebar.render state
    ]
  , Footer.render
  ]

app :: forall m. MonadAff m => PageData -> H.Component HH.HTML Query Unit Void m
app pageData = H.lifecycleComponent
  { initialState: const $ initialState pageData
  , render
  , eval
  , receiver: const Nothing
  , initializer: Just $ H.action Init
  , finalizer: Nothing
  }
  where
  fetchTranscript :: String -> DSL m Unit
  fetchTranscript lang = do
    state <- H.get
    when (not $ FO.member lang state.transcripts) $
      H.liftAff (Api.getTalkTranscript pageData.talk lang) >>= traverse_ \txt ->
        let
          transcript = String.split (String.Pattern "\n") txt
        in
          H.modify_ $ \s -> s
            { transcripts = FO.insert lang transcript s.transcripts
            }

  eval :: Query ~> DSL m
  eval (Init n) = n <$ do
    selectedLang <- H.liftEffect $ window >>= Window.localStorage >>=
      Storage.getItem "languages" >>= \ml -> pure $ case ml of
        Nothing -> OneLang "en"
        Just languages -> case readJSON languages of
          Right [lang] -> OneLang lang
          Right [lang1, lang2] -> TwoLang lang1 lang2
          _ -> OneLang "en"
    H.modify_ $ _ { selectedLang = selectedLang }

    case selectedLang of
      NoLang -> pure unit
      OneLang lang -> fetchTranscript lang
      TwoLang lang1 lang2 ->
        H.fork (fetchTranscript lang1) *> fetchTranscript lang2

  eval (OnClickLang language n) = n <$ do
    fetchTranscript language
    state <- H.get
    let
      selectedLang = case state.selectedLang of
        NoLang -> OneLang language
        OneLang lang ->
          if lang == language
          then NoLang
          else TwoLang lang language
        TwoLang lang1 lang2 ->
          if lang1 == language
          then OneLang lang2
          else
            if lang2 == language
            then OneLang lang1
            else TwoLang lang1 lang2
    H.modify_ $ _ { selectedLang = selectedLang }
    let
      mLangs = case selectedLang of
        NoLang -> Nothing
        OneLang lang -> Just [lang]
        TwoLang lang1 lang2 -> Just [lang1, lang2]
    case mLangs of
      Nothing -> H.liftEffect $ window >>= Window.localStorage >>=
        Storage.removeItem "languages"
      Just langs -> H.liftEffect $ window >>= Window.localStorage >>=
        Storage.setItem "languages" (writeJSON langs)

  eval (OnClickPlay n) = n <$ do
    H.modify_ $ _ { playing = true }

module Talk.App
  ( app
  ) where

import Core.Prelude
import Talk.Types

import Component.Header as Header
import Component.Footer as Footer
import Core.Api as Api
import Core.Model (Talk)
import Data.Array as Array
import Data.MediaType (MediaType(..))
import Data.String as String
import Effect.Aff.Class (class MonadAff)
import Foreign.Object as FO
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Simple.JSON (read, readJSON, writeJSON)
import Talk.Sidebar as Sidebar
import Talk.Util as Util
import Web.HTML (window)
import Web.HTML.Window as Window
import Web.Storage.Storage as Storage

type PageData =
  { talk :: Talk
  }

initialState :: PageData -> State
initialState pageData =
  { talk: pageData.talk
  , selectedLang: NoLang
  , transcripts: FO.empty
  , playing: false
  }

renderTalkInfo :: State -> HTML
renderTalkInfo { talk, selectedLang, playing } =
  HH.div_ $ join
  [ pure $ HH.h1 [ class_ "text-lg mb-3"]
    [ HH.text talk.name ]
  , guard (not playing) $> HH.div [ class_ "flex flex-col lg:flex-row"]
    [ HH.div
      [ class_ "flex-no-shrink cursor-pointer bg-cover bg-center Image"
      , style $ "background-image: url(" <> talk.image <> ")"
      , HE.onClick $ HE.input_ OnClickPlay
      ]
      [ HH.div
        [ class_ "h-full text-white hover:bg-grey300 flex items-center justify-center"]
        [ HH.button
          [ class_ "w-8 h-8 text-white text-3xl PlayButton"
          ]
          [ HH.text "▶" ]
        ]
      ]
    , HH.p [ class_ "mt-2 lg:mt-0 lg:ml-3 leading-normal text-grey500"]
      [ HH.text talk.description ]
    ]
  , guard playing $>
    HH.video
    [ class_ "w-full"
    , HP.controls true
    , HP.autoplay true
    ]
    [ HH.source
      [ HP.type_ $ MediaType "video/mp4"
      , HP.src $ Util.mkVideoUrl talk "950k" ]
    , HH.track
      [ HP.src $ Util.mkTranscriptUrl talk selectedLang "vtt"
      , HP.attr (HH.AttrName "kind") "captions"
      , HP.attr (HH.AttrName "default") ""
      ]
    ]
  ]

renderOneTranscript :: State -> String -> HTML
renderOneTranscript state lang =
  case FO.lookup lang state.transcripts of
    Nothing -> HH.text ""
    Just transcript -> HH.div_ $
      transcript <#> \paragraph ->
        HH.p_
        [ HH.text paragraph]

renderTwoTranscripts :: State -> String -> String -> HTML
renderTwoTranscripts state@{ transcripts } lang1 lang2 =
  case FO.lookup lang1 transcripts, FO.lookup lang2 transcripts of
    Nothing, Nothing -> HH.text ""
    Just _, Nothing -> renderOneTranscript state lang1
    Nothing, Just _ -> renderOneTranscript state lang2
    Just transcript1, Just transcript2 -> HH.div_ $
      Array.zip transcript1 transcript2 <#> \(Tuple p1 p2) ->
        HH.div
        [ class_ "Row pb-4 lg:pb-0" ]
        [ HH.p_
          [ HH.text p1]
        , HH.p_
          [ HH.text p2]
        ]

renderTranscript :: State -> HTML
renderTranscript state =
  HH.article
  [ class_ "mt-6 leading-normal"]
  [ case state.selectedLang of
      NoLang -> HH.text "Select language from sidebar."
      OneLang lang ->
        renderOneTranscript state lang
      TwoLang lang1 lang2 ->
        renderTwoTranscripts state lang1 lang2
  ]

render :: State -> HTML
render state =
  HH.div_
  [ Header.render
  , HH.div
    [ class_ "TalkApp container py-6 px-4 xl:px-0"]
    [ HH.div_
      [ renderTalkInfo state
      , renderTranscript state
      ]
    , Sidebar.render state
    ]
  , Footer.render
  ]

app :: forall m. MonadAff m => PageData -> H.Component HH.HTML Query Unit Void m
app pageData = H.lifecycleComponent
  { initialState: const $ initialState pageData
  , render
  , eval
  , receiver: const Nothing
  , initializer: Just $ H.action Init
  , finalizer: Nothing
  }
  where
  fetchTranscript :: String -> DSL m Unit
  fetchTranscript lang = do
    state <- H.get
    when (not $ FO.member lang state.transcripts) $
      H.liftAff (Api.getTalkTranscript pageData.talk lang) >>= traverse_ \txt ->
        let
          transcript = String.split (String.Pattern "\n") txt
        in
          H.modify_ $ \s -> s
            { transcripts = FO.insert lang transcript s.transcripts
            }

  eval :: Query ~> DSL m
  eval (Init n) = n <$ do
    selectedLang <- H.liftEffect $ window >>= Window.localStorage >>=
      Storage.getItem "languages" >>= \ml -> pure $ case ml of
        Nothing -> OneLang "en"
        Just languages -> case readJSON languages of
          Right [lang] -> OneLang lang
          Right [lang1, lang2] -> TwoLang lang1 lang2
          _ -> OneLang "en"
    H.modify_ $ _ { selectedLang = selectedLang }

    case selectedLang of
      NoLang -> pure unit
      OneLang lang -> fetchTranscript lang
      TwoLang lang1 lang2 ->
        H.fork (fetchTranscript lang1) *> fetchTranscript lang2

  eval (OnClickLang language n) = n <$ do
    fetchTranscript language
    state <- H.get
    let
      selectedLang = case state.selectedLang of
        NoLang -> OneLang language
        OneLang lang ->
          if lang == language
          then NoLang
          else TwoLang lang language
        TwoLang lang1 lang2 ->
          if lang1 == language
          then OneLang lang2
          else
            if lang2 == language
            then OneLang lang1
            else TwoLang lang1 lang2
    H.modify_ $ _ { selectedLang = selectedLang }
    let
      mLangs = case selectedLang of
        NoLang -> Nothing
        OneLang lang -> Just [lang]
        TwoLang lang1 lang2 -> Just [lang1, lang2]
    for_ mLangs $ \langs ->
      H.liftEffect $ window >>= Window.localStorage >>=
        Storage.setItem "languages" (writeJSON langs)

  eval (OnClickPlay n) = n <$ do
    H.modify_ $ _ { playing = true }