Make detail view more beautiful

Make detail view more beautiful

module App.View.LoggedIn where

import Prelude hiding (div)

import App.Events (Event(..))
import App.State
import App.Types
import Data.Maybe (Maybe(..))
import Data.List (List)
import Pux.DOM.HTML (HTML)
import Pux.DOM.Events (onClick, onChange, onInput, targetValue)
import Text.Smolder.HTML
import Text.Smolder.HTML.Attributes as Attributes
import Text.Smolder.Markup ((#!), (!), text, class Attributable)
import Data.Foldable (for_)

getUserName :: Maybe User -> String
getUserName maybeUser = case maybeUser of
  Just (User user) -> user.name
  Nothing -> ""

view :: State -> HTML Event
view (State st) =
  div do
    h1 $ text ( "Bienvenid@ " <> (getUserName st.currentUser))
    div do
      button ! Attributes.className "btn btn-primary" #! onClick (const RequestShoppingLists) $ text "load"
    centralView st.lists (getSelectedList (State st)) st.newItemName
    showAddNewList st.newListName

centralView :: RemoteData GenericLoadingError (List ShoppingList) -> Maybe ShoppingList -> String -> HTML Event
centralView shoppingLists (Just sl) newItemName = div do
   button
     ! Attributes.className "btn btn-secondary mb-3"
     #! onClick (ShoppingListSelected Nothing)
     $ text "back"
   showSelectedList sl newItemName
centralView shoppingLists Nothing _ = showLists shoppingLists

-- TODO: datetime serialization
-- TODO: button for actually deleting?
-- TODO:
-- In a future version, have all lists be "selected", i.e. and in edit mode. then we'd need a component for this to be reusable with a state each
-- Alternatively, the overview in the main page could just be an overview, whereas on detail selection the actual items are loaded. this has the disadvantage of increased loading time

showAddNewList :: String -> HTML Event
showAddNewList newListName =
  div do
    h5 ! Attributes.style "margin-top: 32px" $ text "Add new list"
    input ! Attributes.value newListName #! onInput (\ev -> ChangeNewListName $ targetValue ev)
    (disableIfStringEmpty newListName button) #! onClick (const AddNewList) $ text "add"

disableIfStringEmpty :: forall ta. Attributable ta => String -> ta -> ta
disableIfStringEmpty "" x = x ! Attributes.disabled "disabled"
disableIfStringEmpty _ x = x

createCheckbox :: Boolean -> HTML Event
createCheckbox value = input ! Attributes.type' "checkbox" ! Attributes.checked (if value then "checked" else "" )

showLists :: RemoteData GenericLoadingError (List ShoppingList) -> HTML Event
showLists (Success listList) =
  div do
    span $ text "loaded"
    div $ for_ listList showListInOverview
showLists NotAsked = span $ text "Lists not loading yet"
showLists Loading = span $ text "Loading"
showLists (Failure e) = span $ text $ "Error while loading:" <> show e

showListInOverview :: ShoppingList -> HTML Event
showListInOverview (ShoppingList shoppingList) =
  div do
    a
      -- ! style "cursor: pointer"
      ! Attributes.href "#"
      #! onClick (ShoppingListSelected $ Just $ ShoppingList shoppingList)
      $ text $ "list: " <> shoppingList.name

showSelectedList :: ShoppingList -> String -> HTML Event
showSelectedList (ShoppingList sl) newItemName = div do
  showList (ShoppingList sl) (div $ do
    h5 $ text "Add new item to list"
    input ! Attributes.value newItemName #! onChange (\ev -> ChangeNewItemName $ targetValue ev)
    (disableIfStringEmpty newItemName button ) #! onClick (const $ AddNewItem sl.id) $ text "add"
  )

showList :: ShoppingList -> HTML Event -> HTML Event
showList (ShoppingList shoppingList) transclusion =
  div ! Attributes.className "card mb-3" $ do
     div ! Attributes.className "card-body" $ do
       h3 ! Attributes.className "card-title" $ text shoppingList.name
       ul ! Attributes.className "list-unstyled" $ for_ shoppingList.items showItem
       transclusion

showItem :: Item -> HTML Event
showItem (Item item) = li do
  -- using labels for the checkbox would be the most standard and accessible way,
  -- however it screws up bootstrap styling. so we just make everything clickable here
  div ! Attributes.className "input-group" #! onClick (const $ RequestToggleBoughtState item.id (not item.bought)) $ do
    span ! Attributes.className "input-group-addon" $
      createCheckbox item.bought
    span
      ! Attributes.className "form-control form-control-plaintext"
      -- TODO: extract to proper css style class ("span with input-like border")
      ! Attributes.style "color: black; border-color: rgb(206, 212, 218); border-style: solid ; border-width: 1px;"
      $ text item.name

module App.View.LoggedIn where

import Prelude hiding (div)

import App.Events (Event(..))
import App.State
import App.Types
import Control.Bind (discard)
import Data.Function (($))
import Data.Maybe (fromMaybe, Maybe(..))
import Data.List (List(..), (:), foldl)
import Pux.DOM.HTML (HTML)
import Pux.DOM.Events (onClick, onChange, onInput, targetValue)
import Text.Smolder.HTML hiding (style)
import Text.Smolder.HTML.Attributes hiding (span)
import Text.Smolder.Markup ((#!), (!), text, class Attributable)
import Data.Foldable (for_)

getUserName :: Maybe User -> String
getUserName maybeUser = case maybeUser of
  Just (User user) -> user.name
  Nothing -> ""

view :: State -> HTML Event
view (State st) =
  div do
    h1 $ text ( "Bienvenid@ " <> (getUserName st.currentUser))
    div do
      button ! className "btn btn-primary" #! onClick (const RequestShoppingLists) $ text "load"
    centralView st.lists (getSelectedList (State st)) st.newItemName
    showAddNewList st.newListName

centralView :: RemoteData GenericLoadingError (List ShoppingList) -> Maybe ShoppingList -> String -> HTML Event
centralView shoppingLists (Just sl) newItemName = div do
   button
     ! className "btn btn-secondary mb-3"
     #! onClick (ShoppingListSelected Nothing)
     $ text "back"
   showSelectedList sl newItemName
centralView shoppingLists Nothing _ = showLists shoppingLists

-- TODO: datetime serialization
-- TODO: button for actually deleting?
-- TODO:
-- In a future version, have all lists be "selected", i.e. and in edit mode. then we'd need a component for this to be reusable with a state each
-- Alternatively, the overview in the main page could just be an overview, whereas on detail selection the actual items are loaded. this has the disadvantage of increased loading time

showAddNewList :: String -> HTML Event
showAddNewList newListName =
  div do
    h5 ! style "margin-top: 32px" $ text "Add new list"
    input ! value newListName #! onInput (\ev -> ChangeNewListName $ targetValue ev)
    (disableIfStringEmpty newListName button) #! onClick (const AddNewList) $ text "add"

disableIfStringEmpty :: forall ta. Attributable ta => String -> ta -> ta
disableIfStringEmpty "" x = x ! disabled "disabled"
disableIfStringEmpty _ x = x

createCheckbox :: Boolean -> HTML Event
createCheckbox value = input ! type' "checkbox" ! checked (if value then "checked" else "" )

showItem :: Item -> HTML Event
showItem (Item item) = li do
  text item.name
  createCheckbox item.bought #! onClick (const $ RequestToggleBoughtState item.id (not item.bought))

showLists :: RemoteData GenericLoadingError (List ShoppingList) -> HTML Event
showLists (Success listList) =
  div do
    span $ text "loaded"
    div $ for_ listList showListInOverview
showLists NotAsked = span $ text "Lists not loading yet"
showLists Loading = span $ text "Loading"
showLists (Failure e) = span $ text $ "Error while loading:" <> show e

showListInOverview :: ShoppingList -> HTML Event
showListInOverview (ShoppingList shoppingList) =
  div do
    a
      -- ! style "cursor: pointer"
      ! href "#"
      #! onClick (ShoppingListSelected $ Just $ ShoppingList shoppingList)
      $ text $ "list: " <> shoppingList.name

showSelectedList :: ShoppingList -> String -> HTML Event
showSelectedList (ShoppingList sl) newItemName = div do
  showList (ShoppingList sl)
  h5 $ text "Add new item to list"
  input ! value newItemName #! onChange (\ev -> ChangeNewItemName $ targetValue ev)
  (disableIfStringEmpty newItemName button ) #! onClick (const $ AddNewItem sl.id) $ text "add"

showList :: ShoppingList -> HTML Event
showList (ShoppingList shoppingList) =
  div ! className "card mb-3" $ do
     div ! className "card-body" $ do
       h3 ! className "card-title" $ text shoppingList.name
       ul $ for_ shoppingList.items showItem


Fix out-out-bounds access in unsafeCodePointAt0Fallback

`unsafeCodePointAt0Fallback` crashed when passed a string of length 1
due to always accessing index 1.

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in
-- | `Data.String.CodeUnits`.
module Data.String.CodePoints
  ( module Exports
  , CodePoint
  , codePointFromChar
  , singleton
  , fromCodePointArray
  , toCodePointArray
  , codePointAt
  , uncons
  , length
  , countPrefix
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , take
  -- , takeRight
  , takeWhile
  , drop
  -- , dropRight
  , dropWhile
  -- , slice
  , splitAt
  ) where

import Prelude

import Data.Array as Array
import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), defaultPred, defaultSucc, fromEnum, toEnum, toEnumWithDefaults)
import Data.Int (hexadecimal, toStringAs)
import Data.Maybe (Maybe(..))
import Data.String.CodeUnits (contains, stripPrefix, stripSuffix) as Exports
import Data.String.CodeUnits as CU
import Data.String.Common (toUpper)
import Data.String.Pattern (Pattern)
import Data.String.Unsafe as Unsafe
import Data.Tuple (Tuple(..))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

instance showCodePoint :: Show CodePoint where
  show (CodePoint i) = "(CodePoint 0x" <> toUpper (toStringAs hexadecimal i) <> ")"

instance boundedCodePoint :: Bounded CodePoint where
  bottom = CodePoint 0
  top = CodePoint 0x10FFFF

instance enumCodePoint :: Enum CodePoint where
  succ = defaultSucc toEnum fromEnum
  pred = defaultPred toEnum fromEnum

instance boundedEnumCodePoint :: BoundedEnum CodePoint where
  cardinality = Cardinality (0x10FFFF + 1)
  fromEnum (CodePoint n) = n
  toEnum n
    | n >= 0 && n <= 0x10FFFF = Just (CodePoint n)
    | otherwise = Nothing

-- | Creates a CodePoint from a given Char.
-- |
-- | ```purescript
-- | >>> codePointFromChar 'B'
-- | CodePoint 0x42 -- represents 'B'
-- | ```
-- |
codePointFromChar :: Char -> CodePoint
codePointFromChar = fromEnum >>> CodePoint

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> map singleton (codePointFromInt 0x1D400)
-- | Just "𝐀"
-- | ```
-- |
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "c 𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x63, CodePoint 0x20, CodePoint 0x1D400]
-- | >>> fromCodePointArray codePointArray
-- | "c 𝐀"
-- | ```
-- |
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "b 𝐀𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x62, CodePoint 0x20, CodePoint 0x1D400, CodePoint 0x1D400]
-- | >>> map singleton codePointArray
-- | ["b", " ", "𝐀", "𝐀"]
-- | ```
-- |
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
-- |
-- | ```purescript
-- | >>> codePointAt 1 "𝐀𝐀𝐀𝐀"
-- | Just (CodePoint 0x1D400) -- represents "𝐀"
-- | -- compare to Data.String:
-- | >>> charAt 1 "𝐀𝐀𝐀𝐀"
-- | Just '�'
-- | ```
-- |
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> uncons "𝐀𝐀 c 𝐀"
-- | Just { head: CodePoint 0x1D400, tail: "𝐀 c 𝐀" }
-- | >>> uncons ""
-- | Nothing
-- | ```
-- |
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case CU.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (fromEnum (Unsafe.charAt 0 s)), tail: "" }
  _ ->
    let
      cu0 = fromEnum (Unsafe.charAt 0 s)
      cu1 = fromEnum (Unsafe.charAt 1 s)
    in
      if isLead cu0 && isTrail cu1
        then Just { head: unsurrogate cu0 cu1, tail: CU.drop 2 s }
        else Just { head: CodePoint cu0, tail: CU.drop 1 s }

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 8
-- | -- compare to Data.String:
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 11
-- | ```
-- |
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> countPrefix (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | 2
-- | ```
-- |
countPrefix :: (CodePoint -> Boolean) -> String -> Int
countPrefix = _countPrefix countFallback unsafeCodePointAt0

foreign import _countPrefix
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 2
-- | >>> indexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf :: Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (CU.take i s)) <$> CU.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf' (Pattern "𝐀") 4 "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> indexOf' (Pattern "o") 4 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (CU.take k s')) <$> CU.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> lastIndexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (CU.take i s)) <$> CU.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf' (Pattern "𝐀") 5 "b 𝐀𝐀 c 𝐀"
-- | Just 3
-- | >>> lastIndexOf' (Pattern "o") 5 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = CU.length (take i s) in
  (\k -> length (CU.take k s)) <$> CU.lastIndexOf' p i' s

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
-- |
-- | ```purescript
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b 𝐀"
-- | -- compare to Data.String:
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b �"
-- | ```
-- |
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> takeWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | "𝐀𝐀"
-- | ```
-- |
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (countPrefix p s) s

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
-- |
-- | ```purescript
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "c"
-- | -- compared to Data.String:
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "b c" -- because "𝐀" occupies 2 code units
-- | ```
-- |
drop :: Int -> String -> String
drop n s = CU.drop (CU.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
-- |
-- | ```purescript
-- | >>> dropWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | " b c 𝐀"
-- | ```
-- |
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (countPrefix p s) s

-- | Splits a string into two substrings, where `before` contains the code
-- | points up to (but not including) the given index, and `after` contains the
-- | rest of the string, from that index on.
-- |
-- | ```purescript
-- | >>> splitAt 3 "b 𝐀𝐀 c 𝐀"
-- | { before: "b 𝐀", after: "𝐀 c 𝐀" }
-- | ```
-- |
-- | Thus the length of `(splitAt i s).before` will equal either `i` or
-- | `length s`, if that is shorter. (Or if `i` is negative the length will be
-- | 0.)
-- |
-- | In code:
-- | ```purescript
-- | length (splitAt i s).before == min (max i 0) (length s)
-- | (splitAt i s).before <> (splitAt i s).after == s
-- | splitAt i s == {before: take i s, after: drop i s}
-- | ```
splitAt :: Int -> String -> { before :: String, after :: String }
splitAt i s =
  let before = take i s in
  { before
  -- inline drop i s to reuse the result of take i s
  , after: CU.drop (CU.length before) s
  }

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = CU.singleton <<< toEnumWithDefaults bottom top

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let
    cu0 = fromEnum (Unsafe.charAt 0 s)
  in
    if isLead cu0 && CU.length s > 1
       then
         let cu1 = fromEnum (Unsafe.charAt 1 s) in
         if isTrail cu1 then unsurrogate cu0 cu1 else CodePoint cu0
       else
         CodePoint cu0

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in
-- | `Data.String.CodeUnits`.
module Data.String.CodePoints
  ( module Exports
  , CodePoint
  , codePointFromChar
  , singleton
  , fromCodePointArray
  , toCodePointArray
  , codePointAt
  , uncons
  , length
  , countPrefix
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , take
  -- , takeRight
  , takeWhile
  , drop
  -- , dropRight
  , dropWhile
  -- , slice
  , splitAt
  ) where

import Prelude

import Data.Array as Array
import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), defaultPred, defaultSucc, fromEnum, toEnum, toEnumWithDefaults)
import Data.Int (hexadecimal, toStringAs)
import Data.Maybe (Maybe(..))
import Data.String.CodeUnits (contains, stripPrefix, stripSuffix) as Exports
import Data.String.CodeUnits as CU
import Data.String.Common (toUpper)
import Data.String.Pattern (Pattern)
import Data.String.Unsafe as Unsafe
import Data.Tuple (Tuple(..))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

instance showCodePoint :: Show CodePoint where
  show (CodePoint i) = "(CodePoint 0x" <> toUpper (toStringAs hexadecimal i) <> ")"

instance boundedCodePoint :: Bounded CodePoint where
  bottom = CodePoint 0
  top = CodePoint 0x10FFFF

instance enumCodePoint :: Enum CodePoint where
  succ = defaultSucc toEnum fromEnum
  pred = defaultPred toEnum fromEnum

instance boundedEnumCodePoint :: BoundedEnum CodePoint where
  cardinality = Cardinality (0x10FFFF + 1)
  fromEnum (CodePoint n) = n
  toEnum n
    | n >= 0 && n <= 0x10FFFF = Just (CodePoint n)
    | otherwise = Nothing

-- | Creates a CodePoint from a given Char.
-- |
-- | ```purescript
-- | >>> codePointFromChar 'B'
-- | CodePoint 0x42 -- represents 'B'
-- | ```
-- |
codePointFromChar :: Char -> CodePoint
codePointFromChar = fromEnum >>> CodePoint

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> map singleton (codePointFromInt 0x1D400)
-- | Just "𝐀"
-- | ```
-- |
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "c 𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x63, CodePoint 0x20, CodePoint 0x1D400]
-- | >>> fromCodePointArray codePointArray
-- | "c 𝐀"
-- | ```
-- |
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "b 𝐀𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x62, CodePoint 0x20, CodePoint 0x1D400, CodePoint 0x1D400]
-- | >>> map singleton codePointArray
-- | ["b", " ", "𝐀", "𝐀"]
-- | ```
-- |
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
-- |
-- | ```purescript
-- | >>> codePointAt 1 "𝐀𝐀𝐀𝐀"
-- | Just (CodePoint 0x1D400) -- represents "𝐀"
-- | -- compare to Data.String:
-- | >>> charAt 1 "𝐀𝐀𝐀𝐀"
-- | Just '�'
-- | ```
-- |
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> uncons "𝐀𝐀 c 𝐀"
-- | Just { head: CodePoint 0x1D400, tail: "𝐀 c 𝐀" }
-- | >>> uncons ""
-- | Nothing
-- | ```
-- |
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case CU.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (fromEnum (Unsafe.charAt 0 s)), tail: "" }
  _ ->
    let
      cu0 = fromEnum (Unsafe.charAt 0 s)
      cu1 = fromEnum (Unsafe.charAt 1 s)
    in
      if isLead cu0 && isTrail cu1
        then Just { head: unsurrogate cu0 cu1, tail: CU.drop 2 s }
        else Just { head: CodePoint cu0, tail: CU.drop 1 s }

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 8
-- | -- compare to Data.String:
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 11
-- | ```
-- |
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> countPrefix (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | 2
-- | ```
-- |
countPrefix :: (CodePoint -> Boolean) -> String -> Int
countPrefix = _countPrefix countFallback unsafeCodePointAt0

foreign import _countPrefix
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 2
-- | >>> indexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf :: Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (CU.take i s)) <$> CU.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf' (Pattern "𝐀") 4 "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> indexOf' (Pattern "o") 4 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (CU.take k s')) <$> CU.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> lastIndexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (CU.take i s)) <$> CU.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf' (Pattern "𝐀") 5 "b 𝐀𝐀 c 𝐀"
-- | Just 3
-- | >>> lastIndexOf' (Pattern "o") 5 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = CU.length (take i s) in
  (\k -> length (CU.take k s)) <$> CU.lastIndexOf' p i' s

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
-- |
-- | ```purescript
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b 𝐀"
-- | -- compare to Data.String:
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b �"
-- | ```
-- |
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> takeWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | "𝐀𝐀"
-- | ```
-- |
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (countPrefix p s) s

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
-- |
-- | ```purescript
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "c"
-- | -- compared to Data.String:
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "b c" -- because "𝐀" occupies 2 code units
-- | ```
-- |
drop :: Int -> String -> String
drop n s = CU.drop (CU.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
-- |
-- | ```purescript
-- | >>> dropWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | " b c 𝐀"
-- | ```
-- |
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (countPrefix p s) s

-- | Splits a string into two substrings, where `before` contains the code
-- | points up to (but not including) the given index, and `after` contains the
-- | rest of the string, from that index on.
-- |
-- | ```purescript
-- | >>> splitAt 3 "b 𝐀𝐀 c 𝐀"
-- | { before: "b 𝐀", after: "𝐀 c 𝐀" }
-- | ```
-- |
-- | Thus the length of `(splitAt i s).before` will equal either `i` or
-- | `length s`, if that is shorter. (Or if `i` is negative the length will be
-- | 0.)
-- |
-- | In code:
-- | ```purescript
-- | length (splitAt i s).before == min (max i 0) (length s)
-- | (splitAt i s).before <> (splitAt i s).after == s
-- | splitAt i s == {before: take i s, after: drop i s}
-- | ```
splitAt :: Int -> String -> { before :: String, after :: String }
splitAt i s =
  let before = take i s in
  { before
  -- inline drop i s to reuse the result of take i s
  , after: CU.drop (CU.length before) s
  }

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = CU.singleton <<< toEnumWithDefaults bottom top

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let
    cu0 = fromEnum (Unsafe.charAt 0 s)
    cu1 = fromEnum (Unsafe.charAt 1 s)
  in
    if isLead cu0 && isTrail cu1
       then unsurrogate cu0 cu1
       else CodePoint cu0


add Arg Int instance (#15)

add Arg Int instance (#15)

module Node.Yargs.Applicative
  ( Y
  , runY
  , class Arg
  , arg
  , yarg
  , flag
  , rest
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Control.Monad.Except (runExcept)
import Data.Either (Either(Left, Right))
import Data.Foldable (foldMap)
import Data.Foreign (F, Foreign, readArray, readBoolean, readInt, readNumber, readString)
import Data.Foreign.Index (readProp)
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Data.Traversable (traverse)
import Node.Yargs (runYargs)
import Node.Yargs.Setup (YargsSetup, requiresArg, describe, demand, alias, boolean, string)

-- | The `Y` applicative functor can be used to build values from
-- | command-line arguments, providing a more idiomatic interface to
-- | the `yargs` library.
newtype Y a = Y
  { setup :: YargsSetup
  , read  :: Foreign -> F a
  }

unY :: forall a. Y a -> { setup :: YargsSetup, read :: Foreign -> F a }
unY (Y y) = y

instance functorY :: Functor Y where
  map f (Y o) = Y { setup: o.setup, read: \value -> f <$> o.read value }

instance applyT :: Apply Y where
  apply (Y o1) (Y o2) = Y { setup: o1.setup <> o2.setup
                          , read: \value -> o1.read value <*> o2.read value
                          }

instance applicativeY :: Applicative Y where
  pure a = Y { setup: mempty, read: \_ -> pure a }

-- | Compute some `Eff` action using command-line arguments, and run it.
-- |
-- | This function can throw exceptions.
runY :: forall a eff. YargsSetup ->
                      Y (Eff (exception :: EXCEPTION, console :: CONSOLE | eff) a) ->
                         Eff (exception :: EXCEPTION, console :: CONSOLE | eff) a
runY setup (Y y) = do
  value <- runYargs (setup <> y.setup)
  case runExcept (y.read value) of
    Left err -> throwException (error (show err))
    Right action -> action

-- | The `Arg` class describes types which can be parsed from the command line.
class Arg a where
  arg :: String -> Y a

instance argString :: Arg String where
  arg key = Y { setup: string key
              , read: readProp key >=> readString
              }

instance argBoolean :: Arg Boolean where
  arg key = Y { setup: boolean key
              , read: readProp key >=> readBoolean
              }

instance argNumber :: Arg Number where
  arg key = Y { setup: mempty
              , read: readProp key >=> readNumber
              }

instance argInt :: Arg Int where
  arg key = Y { setup: mempty
              , read: readProp key >=> readInt
              }

readOneOrMany :: forall a. (Foreign -> F a) -> String -> Foreign -> F (Array a)
readOneOrMany f key value = do
  value' <- readProp key value
  pure <$> f value'
       <|> (readArray value' >>= traverse f)

instance argStrings :: Arg (Array String) where
  arg key = Y { setup: string key
              , read: readOneOrMany readString key
              }

instance argBooleans :: Arg (Array Boolean) where
  arg key = Y { setup: boolean key
              , read: readOneOrMany readBoolean key
              }

instance argNumbers :: Arg (Array Number) where
  arg key = Y { setup: mempty
              , read: readOneOrMany readNumber key
              }

-- | Describe a single command line argument.
-- |
-- | The arguments are, in order:
-- |
-- | - The key name and default argument name
-- | - Any aliases which can be used in place of the key
-- | - An optional description
-- | - Either a default value or a message to show if this field is required
-- | - Whether or not an associated value is required
yarg
  :: forall a
   . Arg a
  => String
  -> Array String
  -> Maybe String
  -> Either a String
  -> Boolean
  -> Y a
yarg key aliases desc required needArg =
  let
    y = unY (arg key)
  in Y { setup: y.setup <>
                foldMap (\a -> alias    key a) aliases <>
                foldMap (\m -> demand   key m) required <>
                foldMap (\s -> describe key s) desc <>
                if needArg then requiresArg key else mempty
       , read: case required of
           Left def -> \value -> y.read value <|> pure def
           _ -> y.read
       }

-- | Describe a boolean-valued flag.
-- |
-- | The arguments are, in order:
-- |
-- | - The key name and default argument name
-- | - Any aliases which can be used in place of the key
-- | - An optional description
flag :: String -> Array String -> Maybe String -> Y Boolean
flag key aliases desc = yarg key aliases desc (Left false) false

-- | Get the raw command line arguments object.
rest :: Y (Array Foreign)
rest = Y { setup: mempty
         , read: readProp "_" >=> readArray
         }

module Node.Yargs.Applicative
  ( Y
  , runY
  , class Arg
  , arg
  , yarg
  , flag
  , rest
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Control.Monad.Except (runExcept)
import Data.Either (Either(Left, Right))
import Data.Foldable (foldMap)
import Data.Foreign (F, Foreign, readArray, readBoolean, readNumber, readString)
import Data.Foreign.Index (readProp)
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Data.Traversable (traverse)
import Node.Yargs (runYargs)
import Node.Yargs.Setup (YargsSetup, requiresArg, describe, demand, alias, boolean, string)

-- | The `Y` applicative functor can be used to build values from
-- | command-line arguments, providing a more idiomatic interface to
-- | the `yargs` library.
newtype Y a = Y
  { setup :: YargsSetup
  , read  :: Foreign -> F a
  }

unY :: forall a. Y a -> { setup :: YargsSetup, read :: Foreign -> F a }
unY (Y y) = y

instance functorY :: Functor Y where
  map f (Y o) = Y { setup: o.setup, read: \value -> f <$> o.read value }

instance applyT :: Apply Y where
  apply (Y o1) (Y o2) = Y { setup: o1.setup <> o2.setup
                          , read: \value -> o1.read value <*> o2.read value
                          }

instance applicativeY :: Applicative Y where
  pure a = Y { setup: mempty, read: \_ -> pure a }

-- | Compute some `Eff` action using command-line arguments, and run it.
-- |
-- | This function can throw exceptions.
runY :: forall a eff. YargsSetup ->
                      Y (Eff (exception :: EXCEPTION, console :: CONSOLE | eff) a) ->
                         Eff (exception :: EXCEPTION, console :: CONSOLE | eff) a
runY setup (Y y) = do
  value <- runYargs (setup <> y.setup)
  case runExcept (y.read value) of
    Left err -> throwException (error (show err))
    Right action -> action

-- | The `Arg` class describes types which can be parsed from the command line.
class Arg a where
  arg :: String -> Y a

instance argString :: Arg String where
  arg key = Y { setup: string key
              , read: readProp key >=> readString
              }

instance argBoolean :: Arg Boolean where
  arg key = Y { setup: boolean key
              , read: readProp key >=> readBoolean
              }

instance argNumber :: Arg Number where
  arg key = Y { setup: mempty
              , read: readProp key >=> readNumber
              }

readOneOrMany :: forall a. (Foreign -> F a) -> String -> Foreign -> F (Array a)
readOneOrMany f key value = do
  value' <- readProp key value
  pure <$> f value'
       <|> (readArray value' >>= traverse f)

instance argStrings :: Arg (Array String) where
  arg key = Y { setup: string key
              , read: readOneOrMany readString key
              }

instance argBooleans :: Arg (Array Boolean) where
  arg key = Y { setup: boolean key
              , read: readOneOrMany readBoolean key
              }

instance argNumbers :: Arg (Array Number) where
  arg key = Y { setup: mempty
              , read: readOneOrMany readNumber key
              }

-- | Describe a single command line argument.
-- |
-- | The arguments are, in order:
-- |
-- | - The key name and default argument name
-- | - Any aliases which can be used in place of the key
-- | - An optional description
-- | - Either a default value or a message to show if this field is required
-- | - Whether or not an associated value is required
yarg
  :: forall a
   . Arg a
  => String
  -> Array String
  -> Maybe String
  -> Either a String
  -> Boolean
  -> Y a
yarg key aliases desc required needArg =
  let
    y = unY (arg key)
  in Y { setup: y.setup <>
                foldMap (\a -> alias    key a) aliases <>
                foldMap (\m -> demand   key m) required <>
                foldMap (\s -> describe key s) desc <>
                if needArg then requiresArg key else mempty
       , read: case required of
           Left def -> \value -> y.read value <|> pure def
           _ -> y.read
       }

-- | Describe a boolean-valued flag.
-- |
-- | The arguments are, in order:
-- |
-- | - The key name and default argument name
-- | - Any aliases which can be used in place of the key
-- | - An optional description
flag :: String -> Array String -> Maybe String -> Y Boolean
flag key aliases desc = yarg key aliases desc (Left false) false

-- | Get the raw command line arguments object.
rest :: Y (Array Foreign)
rest = Y { setup: mempty
         , read: readProp "_" >=> readArray
         }


Removed old comment

Removed old comment

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Next.Component.Query where

import SlamData.Prelude
import Data.Lens (TraversalP, wander)
import SlamData.Workspace.Card.Common.EvalQuery (CardEvalQuery)
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.Port (Port)

data Query a
  = AddCard CardType a
  | PresentReason (Maybe Port) CardType a

_AddCardType :: forall a. TraversalP (Query a) CardType
_AddCardType = wander \f s → case s of
  AddCard cty next → flip AddCard next <$> f cty
  PresentReason io card next → pure $ PresentReason io card next

type QueryP = CardEvalQuery ⨁ Query

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Next.Component.Query where

import SlamData.Prelude
import Data.Lens (TraversalP, wander)
import SlamData.Workspace.Card.Common.EvalQuery (CardEvalQuery)
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.Port (Port)

data Query a
  = AddCard CardType a
  | PresentReason (Maybe Port) CardType a

-- This is now partial and I don't know how to fix it.
_AddCardType :: forall a. TraversalP (Query a) CardType
_AddCardType = wander \f s → case s of
  AddCard cty next → flip AddCard next <$> f cty
  PresentReason io card next → pure $ PresentReason io card next

type QueryP = CardEvalQuery ⨁ Query


WIP #1703 - no menu

WIP #1703 - no menu

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ParentHTML Query (Menu.Query AuthenticateOrPresentHelp) Unit Slam
type DSL = H.ParentDSL State Query (Menu.Query AuthenticateOrPresentHelp) Unit Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    $ menu state

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next

  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next

  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next

  Authenticate providerR next → do
    authenticate providerR
    pure next

  PresentAttribution next → do
    H.raise PresentAttributionsDialog
    pure next

  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

    {- H.query unit
      $ H.action
      $ Menu.Set
          { chosen: Nothing
          , submenus: case eProviders of
              _ ->
              -- Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> mempty -- providers
                    }
                  ]
                ⊕
              -- _ → helpMenu
          }
                -}

menu :: forall a. State → Array (H.HTML a Query)
menu state =
  let
    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    submenuItem = HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu ∷ Array (H.HTML a Query) → H.HTML a Query
    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem ∷ ProviderR → H.HTML a Query
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
          [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
          , HE.onClick $ HE.input_ $ Authenticate $ pure provider
          ]
          [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    signInMenu ∷ Array (H.HTML a Query)
    signInMenu =
      case state.providers of
        Nothing → []
        Just ps →
          [ HH.div
            [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
            -- if
            [ HH.button
                [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                , HE.onClick $ HE.input_ $ ToggleMenu SignInMenu
                ]
                [ I.unlockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]

    helpMenu ∷ H.HTML a Query
    helpMenu =
      HH.div
        [ HP.classes [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
          [ HP.class_ $ HH.ClassName "help-menu-button"
          , HE.onClick $ HE.input_ $ ToggleMenu HelpMenu
          ]
          [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                    [ HP.classes $ HH.ClassName <$>
                        [ "menu-item-button", "submenu-item-button"
                    ]
                    , HE.onClick $ HE.input_ $ PresentAttribution
                    ]
                    [ HH.text $ "Attritubion" ]
                  ]
              ]
            ]
          else
            []

  in
    signInMenu <> [ helpMenu ]

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Menu.Component as Menu
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ParentHTML Query (Menu.Query AuthenticateOrPresentHelp) Unit Slam
type DSL = H.ParentDSL State Query (Menu.Query AuthenticateOrPresentHelp) Unit Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    $ menu state

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next

  DismissSubmenu next → do
    _ ← H.query unit $ H.action $ Menu.DismissSubmenu
    pure next

  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next

  Authenticate providerR next → do
    authenticate providerR
    pure next

  PresentAttribution next → do
    H.raise PresentAttributionsDialog
    pure next

  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

    {- H.query unit
      $ H.action
      $ Menu.Set
          { chosen: Nothing
          , submenus: case eProviders of
              _ ->
              -- Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> mempty -- providers
                    }
                  ]
                ⊕
              -- _ → helpMenu
          }
                -}

menu :: forall a. State → Array (H.HTML a Query)
menu state =
  let
    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    submenuItem = HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu ∷ Array (H.HTML a Query) → H.HTML a Query
    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem ∷ ProviderR → H.HTML a Query
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
          [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
          , HE.onClick $ HE.input_ $ Authenticate $ pure provider
          ]
          [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    signInMenu ∷ Array (H.HTML a Query)
    signInMenu =
      case state.providers of
        Nothing → []
        Just ps →
          [ HH.div
            [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
            -- if
            [ HH.button
                [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                , HE.onClick $ HE.input_ $ ToggleMenu SignInMenu
                ]
                [ I.unlockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]

    helpMenu ∷ H.HTML a Query
    helpMenu =
      HH.div
        [ HP.classes [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
          [ HP.class_ $ HH.ClassName "help-menu-button"
          , HE.onClick $ HE.input_ $ ToggleMenu HelpMenu
          ]
          [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                    [ HP.classes $ HH.ClassName <$>
                        [ "menu-item-button", "submenu-item-button"
                    ]
                    , HE.onClick $ HE.input_ $ PresentAttribution
                    ]
                    [ HH.text $ "Attritubion" ]
                  ]
              ]
            ]
          else
            []

  in
    signInMenu <> [ helpMenu ]

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab


Update Skolem to match current psc

Update Skolem to match current psc

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Types
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Data types for types
--
-----------------------------------------------------------------------------

module Language.PureScript.Types where

import Prelude

import Data.Array (concatMap, map, nub)
import Data.Maybe
import Data.Tuple
import Data.Traversable
import Data.Foldable

import Control.Bind
import Control.Monad.Unify

import Control.Arrow (second)

import Language.PureScript.Names
import Language.PureScript.Traversals

-- |
-- An identifier for the scope of a skolem variable
--
data SkolemScope = SkolemScope Number

runSkolemScope :: SkolemScope -> Number
runSkolemScope (SkolemScope n) = n

instance showSkolemScope :: Show SkolemScope where
  show (SkolemScope n) = "SkolemScope " ++ show n

instance eqSkolemScope :: Eq SkolemScope where
  (==) (SkolemScope x) (SkolemScope y) = x == y
  (/=) (SkolemScope x) (SkolemScope y) = x /= y

-- |
-- The type of types
--
data Type
  -- |
  -- A unification variable of type Type
  --
  = TUnknown Unknown
  -- |
  -- A named type variable
  --
  | TypeVar String
  -- |
  -- A type constructor
  --
  | TypeConstructor (Qualified ProperName)
  -- |
  -- A type application
  --
  | TypeApp Type Type
  -- |
  -- A type synonym which is "saturated", i.e. fully applied
  --
  | SaturatedTypeSynonym (Qualified ProperName) [Type]
  -- |
  -- Forall quantifier
  --
  | ForAll String Type (Maybe SkolemScope)
  -- |
  -- A type with a set of type class constraints
  --
  | ConstrainedType [Tuple (Qualified ProperName) [Type]] Type
  -- |
  -- A skolem constant
  --
  | Skolem String Number SkolemScope
  -- |
  -- An empty row
  --
  | REmpty
  -- |
  -- A non-empty row
  --
  | RCons String Type Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintFunction Type Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintArray Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintObject Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintForAll [String] Type

instance showType :: Show Type where
  show (TUnknown u) = "TUnknown " ++ show u
  show (TypeVar var) = "TypeVar " ++ show var
  show (TypeConstructor name) = "TypeConstructor " ++ show name
  show (TypeApp t1 t2) = "TypeApp " ++ show t1 ++ " " ++ show t2
  show (SaturatedTypeSynonym name ts) = "SaturatedTypeSynonym " ++ show name ++ " " ++ show ts
  show (ForAll name ty scope) = "ForAll " ++ show name ++ " " ++ show ty ++ " " ++ show scope
  show (ConstrainedType cs ty) = "ConstrainedType " ++ show cs ++ " " ++ show ty
  show (Skolem s n scope) = "Skolem " ++ show s ++ " " ++ show n ++ " " ++ show scope
  show REmpty = "REmpty"
  show (RCons name t1 t2) = "RCons " ++ show name ++ " " ++ show t1 ++ " " ++ show t2
  show (PrettyPrintFunction t1 t2) = "PrettyPrintFunction " ++ show t1 ++ " " ++ show t2
  show (PrettyPrintArray t) = "PrettyPrintArray " ++ show t
  show (PrettyPrintObject t) = "PrettyPrintObject " ++ show t
  show (PrettyPrintForAll q t) = "PrettyPrintForAll " ++ show q ++ " " ++ show t

instance eqType :: Eq Type where
  (==) (TUnknown u1)                    (TUnknown u2)                     = u1 == u2
  (==) (TypeVar var1)                   (TypeVar var2)                    = var1 == var2
  (==) (TypeConstructor name1)          (TypeConstructor name2)           = name1 == name2
  (==) (TypeApp tx1 ty1)                (TypeApp tx2 ty2)                 = tx1 == tx2 && ty1 == ty2
  (==) (SaturatedTypeSynonym name1 ts1) (SaturatedTypeSynonym name2 ts2)  = name1 == name2 && ts1 == ts2
  (==) (ForAll name1 ty1 scope1)        (ForAll name2 ty2 scope2)         = name1 == name2 && ty1 == ty2 && scope1 == scope2
  (==) (ConstrainedType cs1 ty1)        (ConstrainedType cs2 ty2)         = cs1 == cs2 && ty1 == ty2
  (==) (Skolem s1 n1 scope1)            (Skolem s2 n2 scope2)             = s1 == s2 && n1 == n2 && scope1 == scope2
  (==) REmpty                           REmpty                            = true
  (==) (RCons name1 tx1 ty1)            (RCons name2 tx2 ty2)             = name1 == name2 && tx1 == tx2 && ty1 == ty2
  (==) (PrettyPrintFunction tx1 ty1)    (PrettyPrintFunction tx2 ty2)     = tx1 == tx2 && ty1 == ty2
  (==) (PrettyPrintArray t1)            (PrettyPrintArray t2)             = t1 == t2
  (==) (PrettyPrintObject t1)           (PrettyPrintObject t2)            = t1 == t2
  (==) (PrettyPrintForAll q1 t1)        (PrettyPrintForAll q2 t2)         = q1 == q2 && t1 == t2
  (==) _ _ = false
  (/=) s1 s2 = not (s1 == s2)

-- |
-- Convert a row to a list of pairs of labels and types
--
rowToList :: Type -> Tuple [Tuple String Type] Type
rowToList (RCons name ty row) = case rowToList row of
  (Tuple tys rest) -> Tuple (Tuple name ty : tys) rest
rowToList r = Tuple [] r

-- |
-- Convert a list of labels and types to a row
--
rowFromList :: Tuple [Tuple String Type] Type -> Type
rowFromList (Tuple [] r) = r
rowFromList (Tuple (Tuple name t : ts) r) = RCons name t (rowFromList (Tuple ts r))

-- |
-- Check whether a type is a monotype
--
isMonoType :: Type -> Boolean
isMonoType (ForAll _ _ _) = false
isMonoType _ = true

-- |
-- Universally quantify a type
--
mkForAll :: [String] -> Type -> Type
mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args

-- |
-- Replace a type variable, taking into account variable shadowing
--
replaceTypeVars :: String -> Type -> Type -> Type
replaceTypeVars = replaceTypeVars' []
  where
  replaceTypeVars' bound name replacement = go bound
    where
    go :: [String] -> Type -> Type
    go _  (TypeVar v) | v == name = replacement
    go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)
    go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts
    go bs f@(ForAll v t sco) | v == name = f
    go bs f@(ForAll v t sco) | v `elem` usedTypeVariables replacement =
                                 let v' = genName v (name : bs ++ usedTypeVariables replacement)
                                     t' = replaceTypeVars' bs v (TypeVar v') t
                                 in ForAll v' (go (v' : bs) t') sco
    go bs f@(ForAll v t sco) = ForAll v (go (v : bs) t) sco
    go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)
    go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)
    go _ ty = ty
  genName orig inUse = try 0
    where
    try :: Number -> String
    try n | (orig ++ show n) `elem` inUse = try (n + 1)
    try n = orig ++ show n

-- |
-- Replace named type variables with types
--
replaceAllTypeVars :: [Tuple String Type] -> Type -> Type
replaceAllTypeVars = foldl (\f (Tuple name ty) -> replaceTypeVars name ty <<< f) id

-- |
-- Collect all type variables appearing in a type
--
usedTypeVariables :: Type -> [String]
usedTypeVariables = nub <<< everythingOnTypes (++) go
  where
  go (TypeVar v) = [v]
  go _ = []

-- |
-- Collect all free type variables appearing in a type
--
freeTypeVariables :: Type -> [String]
freeTypeVariables = nub <<< go []
  where
  go :: [String] -> Type -> [String]
  go bound (TypeVar v) | v `notElem` bound = [v]
  go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
  go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
  go bound (ForAll v t _) = go (v : bound) t
  go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) <<< snd) cs ++ go bound t
  go bound (RCons _ t r) = go bound t ++ go bound r
  go _ _ = []

-- |
-- Universally quantify over all type variables appearing free in a type
--
quantify :: Type -> Type
quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty

-- |
-- Move all universal quantifiers to the front of a type
--
moveQuantifiersToFront :: Type -> Type
moveQuantifiersToFront = go [] []
  where
  go qs cs (ForAll q ty sco) = go (Tuple q sco : qs) cs ty
  go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty
  go qs cs ty =
    let constrained = case cs of
                        [] -> ty
                        cs' -> ConstrainedType cs' ty
    in case qs of
         [] -> constrained
         qs' -> foldl (\ty' (Tuple q sco) -> ForAll q ty' sco) constrained qs'

--
-- Traversals
--

everywhereOnTypes :: (Type -> Type) -> Type -> Type
everywhereOnTypes f = go
  where
  go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
  go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))
  go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
  go (ConstrainedType cs ty) = f (ConstrainedType (map ((<$>) (map go)) cs) (go ty))
  go (RCons name ty rest) = f (RCons name (go ty) (go rest))
  go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))
  go (PrettyPrintArray t) = f (PrettyPrintArray (go t))
  go (PrettyPrintObject t) = f (PrettyPrintObject (go t))
  go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))
  go other = f other

everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
everywhereOnTypesTopDown f = go <<< f
  where
  go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
  go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go <<< f) tys)
  go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
  go (ConstrainedType cs ty) = ConstrainedType (map ((<$>) (map (go <<< f))) cs) (go (f ty))
  go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
  go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
  go (PrettyPrintArray t) = PrettyPrintArray (go (f t))
  go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
  go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
  go other = f other

everywhereOnTypesM :: forall m. (Monad m) => (Type -> m Type) -> Type -> m Type
everywhereOnTypesM f = go
  where
  go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
  go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> traverse go tys) >>= f
  go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
  go (ConstrainedType cs ty) = (ConstrainedType <$> traverse (sndM (traverse go)) cs <*> go ty) >>= f
  go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
  go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f
  go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f
  go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f
  go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
  go other = f other

everywhereOnTypesTopDownM :: forall m. (Monad m) => (Type -> m Type) -> Type -> m Type
everywhereOnTypesTopDownM f = go <=< f
  where
  go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
  go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> traverse (go <=< f) tys
  go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
  go (ConstrainedType cs ty) = ConstrainedType <$> traverse (sndM (traverse (go <=< f))) cs <*> (f ty >>= go)
  go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
  go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)
  go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)
  go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)
  go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)
  go other = f other

everythingOnTypes :: forall r. (r -> r -> r) -> (Type -> r) -> Type -> r
everythingOnTypes (<>) f = go
  where
  go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
  go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)
  go t@(ForAll _ ty _) = f t <> go ty
  go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
  go t@(RCons _ ty rest) = f t <> go ty <> go rest
  go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2
  go t@(PrettyPrintArray t1) = f t <> go t1
  go t@(PrettyPrintObject t1) = f t <> go t1
  go t@(PrettyPrintForAll _ t1) = f t <> go t1
  go other = f other

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Types
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Data types for types
--
-----------------------------------------------------------------------------

module Language.PureScript.Types where

import Prelude

import Data.Array (concatMap, map, nub)
import Data.Maybe
import Data.Tuple
import Data.Traversable
import Data.Foldable

import Control.Bind
import Control.Monad.Unify

import Control.Arrow (second)

import Language.PureScript.Names
import Language.PureScript.Traversals

-- |
-- An identifier for the scope of a skolem variable
--
data SkolemScope = SkolemScope Number

runSkolemScope :: SkolemScope -> Number
runSkolemScope (SkolemScope n) = n

instance showSkolemScope :: Show SkolemScope where
  show (SkolemScope n) = "SkolemScope " ++ show n

instance eqSkolemScope :: Eq SkolemScope where
  (==) (SkolemScope x) (SkolemScope y) = x == y
  (/=) (SkolemScope x) (SkolemScope y) = x /= y

-- |
-- The type of types
--
data Type
  -- |
  -- A unification variable of type Type
  --
  = TUnknown Unknown
  -- |
  -- A named type variable
  --
  | TypeVar String
  -- |
  -- A type constructor
  --
  | TypeConstructor (Qualified ProperName)
  -- |
  -- A type application
  --
  | TypeApp Type Type
  -- |
  -- A type synonym which is "saturated", i.e. fully applied
  --
  | SaturatedTypeSynonym (Qualified ProperName) [Type]
  -- |
  -- Forall quantifier
  --
  | ForAll String Type (Maybe SkolemScope)
  -- |
  -- A type with a set of type class constraints
  --
  | ConstrainedType [Tuple (Qualified ProperName) [Type]] Type
  -- |
  -- A skolem constant
  --
  | Skolem Number SkolemScope
  -- |
  -- An empty row
  --
  | REmpty
  -- |
  -- A non-empty row
  --
  | RCons String Type Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintFunction Type Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintArray Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintObject Type
  -- |
  -- A placeholder used in pretty printing
  --
  | PrettyPrintForAll [String] Type

instance showType :: Show Type where
  show (TUnknown u) = "TUnknown " ++ show u
  show (TypeVar var) = "TypeVar " ++ show var
  show (TypeConstructor name) = "TypeConstructor " ++ show name
  show (TypeApp t1 t2) = "TypeApp " ++ show t1 ++ " " ++ show t2
  show (SaturatedTypeSynonym name ts) = "SaturatedTypeSynonym " ++ show name ++ " " ++ show ts
  show (ForAll name ty scope) = "ForAll " ++ show name ++ " " ++ show ty ++ " " ++ show scope
  show (ConstrainedType cs ty) = "ConstrainedType " ++ show cs ++ " " ++ show ty
  show (Skolem n scope) = "Skolem " ++ show n ++ " " ++ show scope
  show REmpty = "REmpty"
  show (RCons name t1 t2) = "RCons " ++ show name ++ " " ++ show t1 ++ " " ++ show t2
  show (PrettyPrintFunction t1 t2) = "PrettyPrintFunction " ++ show t1 ++ " " ++ show t2
  show (PrettyPrintArray t) = "PrettyPrintArray " ++ show t
  show (PrettyPrintObject t) = "PrettyPrintObject " ++ show t
  show (PrettyPrintForAll q t) = "PrettyPrintForAll " ++ show q ++ " " ++ show t

instance eqType :: Eq Type where
  (==) (TUnknown u1)                    (TUnknown u2)                     = u1 == u2
  (==) (TypeVar var1)                   (TypeVar var2)                    = var1 == var2
  (==) (TypeConstructor name1)          (TypeConstructor name2)           = name1 == name2
  (==) (TypeApp tx1 ty1)                (TypeApp tx2 ty2)                 = tx1 == tx2 && ty1 == ty2
  (==) (SaturatedTypeSynonym name1 ts1) (SaturatedTypeSynonym name2 ts2)  = name1 == name2 && ts1 == ts2
  (==) (ForAll name1 ty1 scope1)        (ForAll name2 ty2 scope2)         = name1 == name2 && ty1 == ty2 && scope1 == scope2
  (==) (ConstrainedType cs1 ty1)        (ConstrainedType cs2 ty2)         = cs1 == cs2 && ty1 == ty2
  (==) (Skolem n1 scope1)               (Skolem n2 scope2)                = n1 == n2 && scope1 == scope2
  (==) REmpty                           REmpty                            = true
  (==) (RCons name1 tx1 ty1)            (RCons name2 tx2 ty2)             = name1 == name2 && tx1 == tx2 && ty1 == ty2
  (==) (PrettyPrintFunction tx1 ty1)    (PrettyPrintFunction tx2 ty2)     = tx1 == tx2 && ty1 == ty2
  (==) (PrettyPrintArray t1)            (PrettyPrintArray t2)             = t1 == t2
  (==) (PrettyPrintObject t1)           (PrettyPrintObject t2)            = t1 == t2
  (==) (PrettyPrintForAll q1 t1)        (PrettyPrintForAll q2 t2)         = q1 == q2 && t1 == t2
  (==) _ _ = false
  (/=) s1 s2 = not (s1 == s2)

-- |
-- Convert a row to a list of pairs of labels and types
--
rowToList :: Type -> Tuple [Tuple String Type] Type
rowToList (RCons name ty row) = case rowToList row of
  (Tuple tys rest) -> Tuple (Tuple name ty : tys) rest
rowToList r = Tuple [] r

-- |
-- Convert a list of labels and types to a row
--
rowFromList :: Tuple [Tuple String Type] Type -> Type
rowFromList (Tuple [] r) = r
rowFromList (Tuple (Tuple name t : ts) r) = RCons name t (rowFromList (Tuple ts r))

-- |
-- Check whether a type is a monotype
--
isMonoType :: Type -> Boolean
isMonoType (ForAll _ _ _) = false
isMonoType _ = true

-- |
-- Universally quantify a type
--
mkForAll :: [String] -> Type -> Type
mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args

-- |
-- Replace a type variable, taking into account variable shadowing
--
replaceTypeVars :: String -> Type -> Type -> Type
replaceTypeVars = replaceTypeVars' []
  where
  replaceTypeVars' bound name replacement = go bound
    where
    go :: [String] -> Type -> Type
    go _  (TypeVar v) | v == name = replacement
    go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)
    go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts
    go bs f@(ForAll v t sco) | v == name = f
    go bs f@(ForAll v t sco) | v `elem` usedTypeVariables replacement =
                                 let v' = genName v (name : bs ++ usedTypeVariables replacement)
                                     t' = replaceTypeVars' bs v (TypeVar v') t
                                 in ForAll v' (go (v' : bs) t') sco
    go bs f@(ForAll v t sco) = ForAll v (go (v : bs) t) sco
    go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)
    go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)
    go _ ty = ty
  genName orig inUse = try 0
    where
    try :: Number -> String
    try n | (orig ++ show n) `elem` inUse = try (n + 1)
    try n = orig ++ show n

-- |
-- Replace named type variables with types
--
replaceAllTypeVars :: [Tuple String Type] -> Type -> Type
replaceAllTypeVars = foldl (\f (Tuple name ty) -> replaceTypeVars name ty <<< f) id

-- |
-- Collect all type variables appearing in a type
--
usedTypeVariables :: Type -> [String]
usedTypeVariables = nub <<< everythingOnTypes (++) go
  where
  go (TypeVar v) = [v]
  go _ = []

-- |
-- Collect all free type variables appearing in a type
--
freeTypeVariables :: Type -> [String]
freeTypeVariables = nub <<< go []
  where
  go :: [String] -> Type -> [String]
  go bound (TypeVar v) | v `notElem` bound = [v]
  go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
  go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
  go bound (ForAll v t _) = go (v : bound) t
  go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) <<< snd) cs ++ go bound t
  go bound (RCons _ t r) = go bound t ++ go bound r
  go _ _ = []

-- |
-- Universally quantify over all type variables appearing free in a type
--
quantify :: Type -> Type
quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty

-- |
-- Move all universal quantifiers to the front of a type
--
moveQuantifiersToFront :: Type -> Type
moveQuantifiersToFront = go [] []
  where
  go qs cs (ForAll q ty sco) = go (Tuple q sco : qs) cs ty
  go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty
  go qs cs ty =
    let constrained = case cs of
                        [] -> ty
                        cs' -> ConstrainedType cs' ty
    in case qs of
         [] -> constrained
         qs' -> foldl (\ty' (Tuple q sco) -> ForAll q ty' sco) constrained qs'

--
-- Traversals
--

everywhereOnTypes :: (Type -> Type) -> Type -> Type
everywhereOnTypes f = go
  where
  go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
  go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))
  go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
  go (ConstrainedType cs ty) = f (ConstrainedType (map ((<$>) (map go)) cs) (go ty))
  go (RCons name ty rest) = f (RCons name (go ty) (go rest))
  go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))
  go (PrettyPrintArray t) = f (PrettyPrintArray (go t))
  go (PrettyPrintObject t) = f (PrettyPrintObject (go t))
  go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))
  go other = f other

everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
everywhereOnTypesTopDown f = go <<< f
  where
  go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
  go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go <<< f) tys)
  go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
  go (ConstrainedType cs ty) = ConstrainedType (map ((<$>) (map (go <<< f))) cs) (go (f ty))
  go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
  go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
  go (PrettyPrintArray t) = PrettyPrintArray (go (f t))
  go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
  go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
  go other = f other

everywhereOnTypesM :: forall m. (Monad m) => (Type -> m Type) -> Type -> m Type
everywhereOnTypesM f = go
  where
  go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
  go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> traverse go tys) >>= f
  go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
  go (ConstrainedType cs ty) = (ConstrainedType <$> traverse (sndM (traverse go)) cs <*> go ty) >>= f
  go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
  go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f
  go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f
  go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f
  go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
  go other = f other

everywhereOnTypesTopDownM :: forall m. (Monad m) => (Type -> m Type) -> Type -> m Type
everywhereOnTypesTopDownM f = go <=< f
  where
  go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
  go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> traverse (go <=< f) tys
  go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
  go (ConstrainedType cs ty) = ConstrainedType <$> traverse (sndM (traverse (go <=< f))) cs <*> (f ty >>= go)
  go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
  go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)
  go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)
  go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)
  go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)
  go other = f other

everythingOnTypes :: forall r. (r -> r -> r) -> (Type -> r) -> Type -> r
everythingOnTypes (<>) f = go
  where
  go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
  go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)
  go t@(ForAll _ ty _) = f t <> go ty
  go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
  go t@(RCons _ ty rest) = f t <> go ty <> go rest
  go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2
  go t@(PrettyPrintArray t1) = f t <> go t1
  go t@(PrettyPrintObject t1) = f t <> go t1
  go t@(PrettyPrintForAll _ t1) = f t <> go t1
  go other = f other


Feature: Display client info on the page

module Main where

import Prelude

import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Maybe (Maybe(Just))
import Data.Set as Set

import Graphics.Canvas (CANVAS, Context2D, getCanvasElementById, getContext2D, setFillStyle, fillPath, rect)

import Network.HTTP.Affjax (Affjax, AJAX, get, post)

import Partial.Unsafe (unsafePartial)

import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)

import Text.Smolder.HTML (button, div, h1)
import Text.Smolder.Markup (text, (#!))

import GameState(GameState(GameState), ID(ID), Money(Money), Player(Player))
import Websocket as WS

data Event = Increment | Decrement | NoOp

foldp :: forall fx. Event -> GameState -> EffModel GameState Event fx
foldp Increment (GameState gameState) = { state: GameState $ gameState { hourOfDay = gameState.hourOfDay + 1 }, effects: [] }
foldp Decrement (GameState gameState) = { state: GameState $ gameState { hourOfDay = gameState.hourOfDay - 1 }, effects: [] }
foldp NoOp                         gs = { state: gs                                                           , effects: [] }

view :: GameState -> HTML Event
view (GameState { player: Player { id: (ID identifier), inventory, name, runningTasks, loadsAMoney: (Money money), token, transactions }, goons, competitors, hourOfDay, news }) =
  div do
    button #! onClick (const NoOp) $ text "Hired Hands"
    button #! onClick (const NoOp) $ text "Change displayed items"
    button #! onClick (const NoOp) $ text "Open shop for the day"
    h1 $ text $ "Player ID: "           <> show identifier
    h1 $ text $ "Player inventory: "    <> show inventory
    h1 $ text $ "Player name: "         <> name
    h1 $ text $ "Player's tasks: "      <> show runningTasks
    h1 $ text $ "Player money: "        <> show money
    h1 $ text $ "Player transcations: " <> show transactions
    h1 $ text $ "Token: "               <> token
    h1 $ text $ "Goons "                <> show goons
    h1 $ text $ "Competitors: "         <> show competitors
    h1 $ text $ "Time of day: "         <> show hourOfDay
    h1 $ text $ "News: "                <> show news

getToken :: Eff _ (Canceler _)
getToken = launchAff $ do
  res <- get "/connect"
  liftEff $ continueBooting $ "" <> res.response

postPing :: String -> Eff _ (Canceler _)
postPing token = launchAff $ do
  res <- post "/ping" token
  liftEff $ log $ "POST /ping response: " <> res.response

continueBooting :: forall eff. String -> Eff _ Unit
continueBooting token = do
  WS.init "10.105.144.17"
  _ <- postPing token
  launchPux token
  _ <- initCanvas
  pure unit

launchPux :: forall eff. String -> Eff (CoreEffects eff) Unit
launchPux token = do
  app <- start
    { initialState: makeInitialState token
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input

makeInitialState :: String -> GameState
makeInitialState token = GameState { player: person, goons: Set.empty, competitors: Set.empty, hourOfDay: 0, news: [] }
  where
    person = Player { id: ID 9001, inventory: Set.empty, name: "doofus", runningTasks: Set.empty, loadsAMoney: Money 0, token: token, transactions: [] }

initCanvas :: forall eff. Eff (canvas :: CANVAS | eff) Context2D
initCanvas = unsafePartial do
  Just canvas <- getCanvasElementById "canvas"
  ctx         <- getContext2D canvas
  _           <- setFillStyle "#0000FF" ctx
  fillPath ctx $ rect ctx { x: 250.0, y: 250.0, w: 100.0, h: 100.0 }

main :: Eff _ (Canceler _)
main = getToken

module Main where

import Prelude

import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Maybe (Maybe(Just))
import Data.Set as Set

import Graphics.Canvas (CANVAS, Context2D, getCanvasElementById, getContext2D, setFillStyle, fillPath, rect)

import Network.HTTP.Affjax (Affjax, AJAX, get, post)

import Partial.Unsafe (unsafePartial)

import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)

import Text.Smolder.HTML (button, div, h1)
import Text.Smolder.Markup (text, (#!))

import GameState(GameState(GameState), ID(ID), Money(Money), Player(Player))
import Websocket as WS

data Event = Increment | Decrement | NoOp

foldp :: forall fx. Event -> GameState -> EffModel GameState Event fx
foldp Increment (GameState gameState) = { state: GameState $ gameState { hourOfDay = gameState.hourOfDay + 1 }, effects: [] }
foldp Decrement (GameState gameState) = { state: GameState $ gameState { hourOfDay = gameState.hourOfDay - 1 }, effects: [] }
foldp NoOp                         gs = { state: gs                                                           , effects: [] }

view :: GameState -> HTML Event
view gameState =
  div do
    button #! onClick (const NoOp) $ text "Hired Hands"
    button #! onClick (const NoOp) $ text "Change displayed items"
    button #! onClick (const NoOp) $ text "Open shop for the day"
    h1 $ text $ gameState.player.name

getToken :: Eff _ (Canceler _)
getToken = launchAff $ do
  res <- get "/connect"
  liftEff $ continueBooting $ "" <> res.response

postPing :: String -> Eff _ (Canceler _)
postPing token = launchAff $ do
  res <- post "/ping" token
  liftEff $ log $ "POST /ping response: " <> res.response

continueBooting :: forall eff. String -> Eff _ Unit
continueBooting token = do
  WS.init "10.105.144.17"
  _ <- postPing token
  launchPux token
  _ <- initCanvas
  pure unit

launchPux :: forall eff. String -> Eff (CoreEffects eff) Unit
launchPux token = do
  app <- start
    { initialState: makeInitialState token
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input

makeInitialState :: String -> GameState
makeInitialState token = GameState { player: person, goons: Set.empty, competitors: Set.empty, hourOfDay: 0, news: [] }
  where
    person = Player { id: ID 9001, inventory: Set.empty, name: "doofus", runningTasks: Set.empty, loadsAMoney: Money 0, token: token, transactions: [] }

initCanvas :: forall eff. Eff (canvas :: CANVAS | eff) Context2D
initCanvas = unsafePartial do
  Just canvas <- getCanvasElementById "canvas"
  ctx         <- getContext2D canvas
  _           <- setFillStyle "#0000FF" ctx
  fillPath ctx $ rect ctx { x: 250.0, y: 250.0, w: 100.0, h: 100.0 }

main :: Eff _ (Canceler _)
main = getToken


Add parsing for Code so we can extract it from query params

module Lambda.Language.Snapshot.Code
  ( Code(..)
  ) where

import Lambda.Prelude

import Data.String.Pattern (Pattern(..))
import Data.String.CodeUnits (contains, singleton, fromCharArray)
import Lambda.Language.Parser (liftJson, satisfy, class Parse, parse)

-- | Identifies a snapshot
newtype Code = Code String

derive instance newtypeCode :: Newtype Code _
derive newtype instance eqCode :: Eq Code
derive newtype instance showCode :: Show Code
derive newtype instance encodeJsonCode :: EncodeJson Code

instance decodeJsonCode :: DecodeJson Code where
  decodeJson = liftJson parse <=< decodeJson

instance parseCode :: Parse Code where
  parse = (Code <<< fromCharArray) <$> replicateA 8 (satisfy isCodeChar)

isCodeChar :: Char -> Boolean
isCodeChar c = isDigit || (isUpper && not ambiguous)
 where
  isDigit = '0' <= c && c <= '9'
  isUpper = 'A' <= c && c <= 'Z'
  ambiguous = contains pat "ILOU"
  pat = Pattern $ singleton c

module Lambda.Language.Snapshot.Code
  ( Code(..)
  ) where

import Lambda.Prelude

-- | Identifies a snapshot
newtype Code = Code String

derive instance newtypeCode :: Newtype Code _
derive newtype instance eqCode :: Eq Code
derive newtype instance showCode :: Show Code
derive newtype instance encodeJsonCode :: EncodeJson Code
derive newtype instance decodeJsonCode :: DecodeJson Code