Constrait exports more

Constrait exports more

module Test.Spec.Reporter.Summary (
  printSummary
  ) where

import Debug.Trace
import Control.Monad.Eff
import Test.Spec
import Test.Spec.Summary
import Test.Spec.Console

pluralize :: String -> Number -> String
pluralize s 1 = s
pluralize s _ = s ++ "s"

printPassedFailed :: forall r. Number -> Number -> Eff (trace :: Trace | r) Unit
printPassedFailed p f = do
  let total = p + f
      testStr = pluralize "test" total
      amount = show p ++ "/" ++ (show total) ++ " " ++ testStr ++ " passed"
      attrs = if f > 0 then [31] else [32]
  withAttrs attrs $ writeln amount

printPending :: forall r. Number -> Eff (trace :: Trace | r) Unit
printPending p =
  if p > 0 then withAttrs [33] do write $ show p
                                  write " "
                                  write (pluralize "test" p)
                                  writeln " pending"
           else return unit

printSummary' :: forall r. Summary -> Eff (trace :: Trace | r) Unit
printSummary' (Count passed failed pending) = do
  writeln ""
  withAttrs [1] $ writeln "Summary"
  printPassedFailed passed failed
  printPending pending
  writeln ""

printSummary :: forall r. [Group] -> Eff (trace :: Trace | r) Unit
printSummary groups = printSummary' $ summarize groups

module Test.Spec.Reporter.Summary where

import Debug.Trace
import Control.Monad.Eff
import Test.Spec
import Test.Spec.Summary
import Test.Spec.Console

pluralize :: String -> Number -> String
pluralize s 1 = s
pluralize s _ = s ++ "s"

printPassedFailed :: forall r. Number -> Number -> Eff (trace :: Trace | r) Unit
printPassedFailed p f = do
  let total = p + f
      testStr = pluralize "test" total
      amount = show p ++ "/" ++ (show total) ++ " " ++ testStr ++ " passed"
      attrs = if f > 0 then [31] else [32]
  withAttrs attrs $ writeln amount

printPending :: forall r. Number -> Eff (trace :: Trace | r) Unit
printPending p =
  if p > 0 then withAttrs [33] do write $ show p
                                  write " "
                                  write (pluralize "test" p)
                                  writeln " pending"
           else return unit

printSummary' :: forall r. Summary -> Eff (trace :: Trace | r) Unit
printSummary' (Count passed failed pending) = do
  writeln ""
  withAttrs [1] $ writeln "Summary"
  printPassedFailed passed failed
  printPending pending
  writeln ""

printSummary :: forall r. [Group] -> Eff (trace :: Trace | r) Unit
printSummary groups = printSummary' $ summarize groups


More work on parsing values

More work on parsing values

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Parser.Declarations
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Parsers for module definitions and declarations
--
-----------------------------------------------------------------------------

module Language.PureScript.Parser.Declarations (
    parseDeclaration,
    parseModule,
    parseModules,
    parseValue,
    parseGuard,
    parseBinder,
    parseBinderNoParens
  ) where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Foldable (foldr)

import Control.Apply

import Language.PureScript.Pos
import Language.PureScript.Declarations
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
import Language.PureScript.Parser.Common

import qualified Language.PureScript.Parser.Lexer as L

import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Expr as P

parseDataDeclaration :: P.Parser [L.Token] Declaration
parseDataDeclaration = do
  reserved "data"
  name <- properName
  tyArgs <- P.many identifier
  ctors <- P.option [] $ do
    equals
    P.sepBy1 (Tuple <$> properName <*> P.many parseTypeAtom) pipe
  return $ DataDeclaration name tyArgs ctors

parseTypeDeclaration :: P.Parser [L.Token] Declaration
parseTypeDeclaration =
  TypeDeclaration <$> P.try (ident <* doubleColon)
                  <*> parseType

parseTypeSynonymDeclaration :: P.Parser [L.Token] Declaration
parseTypeSynonymDeclaration =
  TypeSynonymDeclaration <$> (reserved "type" *> properName)
                         <*> P.many identifier
                         <*> (equals *> parseType)

parseValueDeclaration :: {} -> P.Parser [L.Token] Declaration
parseValueDeclaration _ = do
  name <- ident
  binders <- P.many parseBinderNoParens
  guard <- P.optionMaybe parseGuard
  value <- equals *> parseValue
  whereClause <- P.optionMaybe $ do
    reserved "where"
    braces (semiSep1 (parseLocalDeclaration {}))
  return $ ValueDeclaration name Value binders guard (maybe value (\ds -> Let ds value) whereClause)

parseExternDeclaration :: P.Parser [L.Token] Declaration
parseExternDeclaration = reserved "foreign" *> reserved "import" *>
   ((do reserved "data"
        name <- properName
        doubleColon
        kind <- parseKind
        return $ ExternDataDeclaration name kind)
    <|> (do reserved "instance"
            name <- ident
            doubleColon
            deps <- P.option [] do
              deps <- parens (commaSep1 (Tuple <$> parseQualified properName <*> P.many parseTypeAtom))
              rfatArrow
              return deps
            className <- parseQualified properName
            tys <- P.many parseTypeAtom
            return $ ExternInstanceDeclaration name deps className tys)
    <|> (do ident <- ident
            js <- P.optionMaybe (JSRaw <$> stringLiteral)
            doubleColon
            ty <- parseType
            return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))

parseAssociativity :: P.Parser [L.Token] Associativity
parseAssociativity =
  (reserved "infixl" *> return Infixl) <|>
  (reserved "infixr" *> return Infixr) <|>
  (reserved "infix"  *> return Infix)

parseFixity :: P.Parser [L.Token] Fixity
parseFixity = Fixity <$> parseAssociativity <*> natural

parseFixityDeclaration :: P.Parser [L.Token] Declaration
parseFixityDeclaration = do
  fixity <- parseFixity
  name <- symbol
  return $ FixityDeclaration fixity name

parseDeclarationRef :: P.Parser [L.Token] DeclarationRef
parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
  (ValueRef <$> ident
   <|> do name <- properName
          dctors <- P.optionMaybe $ parens ((symbol' ".." *> pure Nothing) <|> Just <$> commaSep properName)
          return $ maybe (TypeClassRef name) (TypeRef name) dctors)

parseImportDeclaration :: P.Parser [L.Token] Declaration
parseImportDeclaration = do
  reserved "import"
  qualImport <|> stdImport
  where

  stdImport :: P.Parser [L.Token] Declaration
  stdImport = do
    moduleName' <- moduleName
    idents <- P.optionMaybe (parens $ commaSep parseDeclarationRef)
    return $ ImportDeclaration moduleName' idents Nothing

  qualImport :: P.Parser [L.Token] Declaration
  qualImport = do
    reserved "qualified"
    moduleName' <- moduleName
    idents <- P.optionMaybe (parens $ commaSep parseDeclarationRef)
    reserved "as"
    asQ <- moduleName
    return $ ImportDeclaration moduleName' idents (Just asQ)

parseTypeClassDeclaration :: P.Parser [L.Token] Declaration
parseTypeClassDeclaration = do
  reserved "class"
  implies <- P.option [] do
    implies <- parens (commaSep1 (Tuple <$> parseQualified properName <*> P.many parseTypeAtom))
    lfatArrow
    return implies
  className <- properName
  idents <- P.many identifier
  members <- P.option [] $ do
    reserved "where"
    braces (semiSep1 (positioned parseTypeDeclaration))
  return $ TypeClassDeclaration className idents implies members

parseTypeInstanceDeclaration :: P.Parser [L.Token] Declaration
parseTypeInstanceDeclaration = do
  reserved "instance"
  name <- ident <* doubleColon
  deps <- P.optionMaybe $ parens (commaSep1 (Tuple <$> parseQualified properName <*> P.many parseTypeAtom)) <* rfatArrow
  className <- parseQualified properName
  ty <- P.many parseTypeAtom
  members <- P.option [] $ do
    reserved "where"
    P.many (positioned (parseValueDeclaration {}))
  return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members

positioned :: P.Parser [L.Token] Declaration -> P.Parser [L.Token] Declaration
positioned d = PositionedDeclaration <$> sourcePos <*> d

-- |
-- Parse a single declaration
--
parseDeclaration :: P.Parser [L.Token] Declaration
parseDeclaration = positioned (P.choice
                   [ parseDataDeclaration
                   , parseTypeDeclaration
                   , parseTypeSynonymDeclaration
                   , parseValueDeclaration {}
                   , parseExternDeclaration
                   , parseFixityDeclaration
                   , parseImportDeclaration
                   , parseTypeClassDeclaration
                   , parseTypeInstanceDeclaration
                   ]) P.<?> "declaration"

parseLocalDeclaration :: {} -> P.Parser [L.Token] Declaration
parseLocalDeclaration _ = PositionedDeclaration <$> sourcePos <*> P.choice
                   [ parseTypeDeclaration
                   , parseValueDeclaration {}
                   ] P.<?> "local declaration"

-- |
-- Parse a module header and a collection of declarations
--
parseModule :: P.Parser [L.Token] Module
parseModule = do
  reserved "module"
  name <- moduleName
  exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
  reserved "where"
  decls <- braces (semiSep parseDeclaration)
  return $ Module name decls exports

-- |
-- Parse a collection of modules
--
parseModules :: P.Parser [L.Token] [Module]
parseModules = P.many parseModule <* eof

--
-- Values
--

booleanLiteral :: P.Parser [L.Token] Boolean
booleanLiteral = (reserved "true" *> return true) <|> (reserved "false" *> return false)

parseNumericLiteral :: P.Parser [L.Token] Value
parseNumericLiteral = NumericLiteral <$> (natural <|> integer <|> float <|> hex)

parseStringLiteral :: P.Parser [L.Token] Value
parseStringLiteral = StringLiteral <$> stringLiteral

parseBooleanLiteral :: P.Parser [L.Token] Value
parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

parseArrayLiteral :: P.Parser [L.Token] Value
parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

parseObjectLiteral :: P.Parser [L.Token] Value
parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

parseIdentifierAndValue :: P.Parser [L.Token] (Tuple String Value)
parseIdentifierAndValue = Tuple <$> ((identifier <|> stringLiteral) <* colon)
                                <*> parseValue

parseAbs :: P.Parser [L.Token] Value
parseAbs = do
  symbol' "\\"
  args <- P.many1 (Abs <$> (Left <$> P.try ident <|> Right <$> parseBinderNoParens))
  rarrow
  value <- parseValue
  return $ toFunction args value
  where
  toFunction :: [Value -> Value] -> Value -> Value
  toFunction args value = foldr ($) value args

parseVar :: P.Parser [L.Token] Value
parseVar = Var <$> parseQualified ident

parseConstructor :: P.Parser [L.Token] Value
parseConstructor = Constructor <$> parseQualified properName

parseCase :: P.Parser [L.Token] Value
parseCase = Case <$> P.between (P.try (reserved "case")) (reserved "of") (return <$> parseValue)
                 <*> P.many parseCaseAlternative

parseCaseAlternative :: P.Parser [L.Token] CaseAlternative
parseCaseAlternative = mkCaseAlternative <$> (return <$> parseBinder)
                                         <*> P.optionMaybe parseGuard
                                         <*> (rarrow *> parseValue)
                                         P.<?> "case alternative"

parseIfThenElse :: P.Parser [L.Token] Value
parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> parseValue)
                             <*> (reserved "then" *> parseValue)
                             <*> (reserved "else" *> parseValue)

parseDo :: P.Parser [L.Token] Value
parseDo = do
  reserved "do"
  Do <$> P.many parseDoNotationElement

parseDoNotationLet :: P.Parser [L.Token] DoNotationElement
parseDoNotationLet = DoNotationLet <$> (reserved "let" *> P.many1 (parseLocalDeclaration {}))

parseDoNotationBind :: P.Parser [L.Token] DoNotationElement
parseDoNotationBind = DoNotationBind <$> parseBinder <*> (larrow *> parseValue)

parseDoNotationElement :: P.Parser [L.Token] DoNotationElement
parseDoNotationElement = P.choice
  [ P.try parseDoNotationBind
  , parseDoNotationLet
  , P.try (DoNotationValue <$> parseValue) ]

parseLet :: P.Parser [L.Token] Value
parseLet = do
  reserved "let"
  ds <- P.many1 (parseLocalDeclaration {})
  reserved "in"
  result <- parseValue
  return $ Let ds result

parseValueAtom :: P.Parser [L.Token] Value
parseValueAtom = P.choice
  [ parseNumericLiteral
  , parseStringLiteral
  , parseBooleanLiteral
  , parseArrayLiteral
  , P.try parseObjectLiteral
  , parseAbs
  , P.try parseConstructor
  , P.try parseVar
  , parseCase
  , parseIfThenElse
  , parseDo
  , parseLet
  , Parens <$> parens parseValue ]

parseValue :: P.Parser [L.Token] Value
parseValue = P.fail "Not implemented"

parseGuard :: P.Parser [L.Token] Value
parseGuard = P.fail "Not implemented"

parseBinder :: P.Parser [L.Token] Binder
parseBinder = P.fail "Not implemented"

parseBinderNoParens :: P.Parser [L.Token] Binder
parseBinderNoParens = P.fail "Not implemented"

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Parser.Declarations
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Parsers for module definitions and declarations
--
-----------------------------------------------------------------------------

module Language.PureScript.Parser.Declarations (
    parseDeclaration,
    parseModule,
    parseModules,
    parseValue,
    parseGuard,
    parseBinder,
    parseBinderNoParens
  ) where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Foldable (foldr)

import Control.Apply

import Language.PureScript.Pos
import Language.PureScript.Declarations
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
import Language.PureScript.Parser.Common

import qualified Language.PureScript.Parser.Lexer as L

import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Expr as P

parseDataDeclaration :: P.Parser [L.Token] Declaration
parseDataDeclaration = do
  reserved "data"
  name <- properName
  tyArgs <- P.many identifier
  ctors <- P.option [] $ do
    equals
    P.sepBy1 (Tuple <$> properName <*> P.many parseTypeAtom) pipe
  return $ DataDeclaration name tyArgs ctors

parseTypeDeclaration :: P.Parser [L.Token] Declaration
parseTypeDeclaration =
  TypeDeclaration <$> P.try (ident <* doubleColon)
                  <*> parseType

parseTypeSynonymDeclaration :: P.Parser [L.Token] Declaration
parseTypeSynonymDeclaration =
  TypeSynonymDeclaration <$> (reserved "type" *> properName)
                         <*> P.many identifier
                         <*> (equals *> parseType)

parseValueDeclaration :: P.Parser [L.Token] Declaration
parseValueDeclaration = P.fix $ \p ->
  let
    parseLocalDeclaration :: P.Parser [L.Token] Declaration
    parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
                       [ parseTypeDeclaration
                       , p
                       ] P.<?> "local declaration"
  in do
    name <- ident
    binders <- P.many parseBinderNoParens
    guard <- P.optionMaybe parseGuard
    value <- equals *> parseValue
    whereClause <- P.optionMaybe $ do
      reserved "where"
      braces (semiSep1 parseLocalDeclaration)
    return $ ValueDeclaration name Value binders guard (maybe value (\ds -> Let ds value) whereClause)

parseExternDeclaration :: P.Parser [L.Token] Declaration
parseExternDeclaration = reserved "foreign" *> reserved "import" *>
   ((do reserved "data"
        name <- properName
        doubleColon
        kind <- parseKind
        return $ ExternDataDeclaration name kind)
    <|> (do reserved "instance"
            name <- ident
            doubleColon
            deps <- P.option [] do
              deps <- parens (commaSep1 (Tuple <$> parseQualified properName <*> P.many parseTypeAtom))
              rfatArrow
              return deps
            className <- parseQualified properName
            tys <- P.many parseTypeAtom
            return $ ExternInstanceDeclaration name deps className tys)
    <|> (do ident <- ident
            js <- P.optionMaybe (JSRaw <$> stringLiteral)
            doubleColon
            ty <- parseType
            return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))

parseAssociativity :: P.Parser [L.Token] Associativity
parseAssociativity =
  (reserved "infixl" *> return Infixl) <|>
  (reserved "infixr" *> return Infixr) <|>
  (reserved "infix"  *> return Infix)

parseFixity :: P.Parser [L.Token] Fixity
parseFixity = Fixity <$> parseAssociativity <*> natural

parseFixityDeclaration :: P.Parser [L.Token] Declaration
parseFixityDeclaration = do
  fixity <- parseFixity
  name <- symbol
  return $ FixityDeclaration fixity name

parseDeclarationRef :: P.Parser [L.Token] DeclarationRef
parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
  (ValueRef <$> ident
   <|> do name <- properName
          dctors <- P.optionMaybe $ parens ((symbol' ".." *> pure Nothing) <|> Just <$> commaSep properName)
          return $ maybe (TypeClassRef name) (TypeRef name) dctors)

parseImportDeclaration :: P.Parser [L.Token] Declaration
parseImportDeclaration = do
  reserved "import"
  qualImport <|> stdImport
  where

  stdImport :: P.Parser [L.Token] Declaration
  stdImport = do
    moduleName' <- moduleName
    idents <- P.optionMaybe (parens $ commaSep parseDeclarationRef)
    return $ ImportDeclaration moduleName' idents Nothing

  qualImport :: P.Parser [L.Token] Declaration
  qualImport = do
    reserved "qualified"
    moduleName' <- moduleName
    idents <- P.optionMaybe (parens $ commaSep parseDeclarationRef)
    reserved "as"
    asQ <- moduleName
    return $ ImportDeclaration moduleName' idents (Just asQ)

parseTypeClassDeclaration :: P.Parser [L.Token] Declaration
parseTypeClassDeclaration = do
  reserved "class"
  implies <- P.option [] do
    implies <- parens (commaSep1 (Tuple <$> parseQualified properName <*> P.many parseTypeAtom))
    lfatArrow
    return implies
  className <- properName
  idents <- P.many identifier
  members <- P.option [] <<< P.try $ do
    reserved "where"
    braces (semiSep1 (positioned parseTypeDeclaration))
  return $ TypeClassDeclaration className idents implies members

positioned :: P.Parser [L.Token] Declaration -> P.Parser [L.Token] Declaration
positioned d = PositionedDeclaration <$> sourcePos <*> d

-- |
-- Parse a single declaration
--
parseDeclaration :: P.Parser [L.Token] Declaration
parseDeclaration = positioned (P.choice
                   [ parseDataDeclaration
                   , parseTypeDeclaration
                   , parseTypeSynonymDeclaration
                   , parseValueDeclaration
                   , parseExternDeclaration
                   , parseFixityDeclaration
                   , parseImportDeclaration
                   , parseTypeClassDeclaration
                   -- , parseTypeInstanceDeclaration
                   ]) P.<?> "declaration"

-- |
-- Parse a module header and a collection of declarations
--
parseModule :: P.Parser [L.Token] Module
parseModule = do
  reserved "module"
  name <- moduleName
  exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
  reserved "where"
  decls <- braces (semiSep parseDeclaration)
  return $ Module name decls exports

-- |
-- Parse a collection of modules
--
parseModules :: P.Parser [L.Token] [Module]
parseModules = P.many parseModule <* eof

--
-- Values
--

booleanLiteral :: P.Parser [L.Token] Boolean
booleanLiteral = (reserved "true" *> return true) <|> (reserved "false" *> return false)

parseNumericLiteral :: P.Parser [L.Token] Value
parseNumericLiteral = NumericLiteral <$> (natural <|> integer <|> float <|> hex)

parseStringLiteral :: P.Parser [L.Token] Value
parseStringLiteral = StringLiteral <$> stringLiteral

parseBooleanLiteral :: P.Parser [L.Token] Value
parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

parseArrayLiteral :: P.Parser [L.Token] Value
parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

parseObjectLiteral :: P.Parser [L.Token] Value
parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

parseIdentifierAndValue :: P.Parser [L.Token] (Tuple String Value)
parseIdentifierAndValue = Tuple <$> ((identifier <|> stringLiteral) <* colon)
                                <*> parseValue

parseAbs :: P.Parser [L.Token] Value
parseAbs = do
  symbol' "\\"
  args <- P.many1 (Abs <$> (Left <$> P.try ident <|> Right <$> parseBinderNoParens))
  rarrow
  value <- parseValue
  return $ toFunction args value
  where
  toFunction :: [Value -> Value] -> Value -> Value
  toFunction args value = foldr ($) value args

parseVar :: P.Parser [L.Token] Value
parseVar = Var <$> parseQualified ident

parseConstructor :: P.Parser [L.Token] Value
parseConstructor = Constructor <$> parseQualified properName

parseCase :: P.Parser [L.Token] Value
parseCase = Case <$> P.between (P.try (reserved "case")) (reserved "of") (return <$> parseValue)
                 <*> P.many parseCaseAlternative

parseCaseAlternative :: P.Parser [L.Token] CaseAlternative
parseCaseAlternative = mkCaseAlternative <$> (return <$> parseBinder)
                                         <*> P.optionMaybe parseGuard
                                         <*> (rarrow *> parseValue)
                                         P.<?> "case alternative"

parseIfThenElse :: P.Parser [L.Token] Value
parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> parseValue)
                             <*> (reserved "then" *> parseValue)
                             <*> (reserved "else" *> parseValue)

parseValue :: P.Parser [L.Token] Value
parseValue = P.fail "Not implemented"

parseGuard :: P.Parser [L.Token] Value
parseGuard = P.fail "Not implemented"

parseBinder :: P.Parser [L.Token] Binder
parseBinder = P.fail "Not implemented"

parseBinderNoParens :: P.Parser [L.Token] Binder
parseBinderNoParens = P.fail "Not implemented"


Add examples for `power` (#253)

Add examples for `power` (#253)

module Data.Monoid
  ( class Monoid, mempty
  , power
  , guard
  , module Data.Semigroup
  , class MonoidRecord, memptyRecord
  ) where

import Data.Boolean (otherwise)
import Data.Eq ((==))
import Data.EuclideanRing (mod, (/))
import Data.Ord ((<=))
import Data.Ordering (Ordering(..))
import Data.Semigroup (class Semigroup, class SemigroupRecord, (<>))
import Data.Symbol (class IsSymbol, reflectSymbol)
import Data.Unit (Unit, unit)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeSet)
import Type.Proxy (Proxy(..))

-- | A `Monoid` is a `Semigroup` with a value `mempty`, which is both a
-- | left and right unit for the associative operation `<>`:
-- |
-- | - Left unit: `(mempty <> x) = x`
-- | - Right unit: `(x <> mempty) = x`
-- |
-- | `Monoid`s are commonly used as the result of fold operations, where
-- | `<>` is used to combine individual results, and `mempty` gives the result
-- | of folding an empty collection of elements.
-- |
-- | ### Newtypes for Monoid
-- |
-- | Some types (e.g. `Int`, `Boolean`) can implement multiple law-abiding
-- | instances for `Monoid`. Let's use `Int` as an example
-- | 1. `<>` could be `+` and `mempty` could be `0`
-- | 2. `<>` could be `*` and `mempty` could be `1`.
-- |
-- | To clarify these ambiguous situations, one should use the newtypes
-- | defined in `Data.Monoid.<NewtypeName>` modules.
-- |
-- | In the above ambiguous situation, we could use `Additive`
-- | for the first situation or `Multiplicative` for the second one.
class Semigroup m <= Monoid m where
  mempty :: m

instance monoidUnit :: Monoid Unit where
  mempty = unit

instance monoidOrdering :: Monoid Ordering where
  mempty = EQ

instance monoidFn :: Monoid b => Monoid (a -> b) where
  mempty _ = mempty

instance monoidString :: Monoid String where
  mempty = ""

instance monoidArray :: Monoid (Array a) where
  mempty = []

instance monoidRecord :: (RL.RowToList row list, MonoidRecord list row row) => Monoid (Record row) where
  mempty = memptyRecord (Proxy :: Proxy list)

-- | Append a value to itself a certain number of times. For the
-- | `Multiplicative` type, and for a non-negative power, this is the same as
-- | normal number exponentiation.
-- |
-- | If the second argument is negative this function will return `mempty`
-- | (*unlike* normal number exponentiation). The `Monoid` constraint alone
-- | is not enough to write a `power` function with the property that `power x
-- | n` cancels with `power x (-n)`, i.e. `power x n <> power x (-n) = mempty`.
-- | For that, we would additionally need the ability to invert elements, i.e.
-- | a Group.
-- |
-- | ```purescript
-- | power [1,2] 3    == [1,2,1,2,1,2]
-- | power [1,2] 1    == [1,2]
-- | power [1,2] 0    == []
-- | power [1,2] (-3) == []
-- | ```
-- |
power :: forall m. Monoid m => m -> Int -> m
power x = go
  where
  go :: Int -> m
  go p
    | p <= 0 = mempty
    | p == 1 = x
    | p `mod` 2 == 0 = let x' = go (p / 2) in x' <> x'
    | otherwise = let x' = go (p / 2) in x' <> x' <> x

-- | Allow or "truncate" a Monoid to its `mempty` value based on a condition.
guard :: forall m. Monoid m => Boolean -> m -> m
guard true a = a
guard false _ = mempty

-- | A class for records where all fields have `Monoid` instances, used to
-- | implement the `Monoid` instance for records.
class MonoidRecord :: RL.RowList Type -> Row Type -> Row Type -> Constraint
class SemigroupRecord rowlist row subrow <= MonoidRecord rowlist row subrow | rowlist -> row subrow where
  memptyRecord :: forall rlproxy. rlproxy rowlist -> Record subrow

instance monoidRecordNil :: MonoidRecord RL.Nil row () where
  memptyRecord _ = {}

instance monoidRecordCons
    :: ( IsSymbol key
       , Monoid focus
       , Row.Cons key focus subrowTail subrow
       , MonoidRecord rowlistTail row subrowTail
       )
    => MonoidRecord (RL.Cons key focus rowlistTail) row subrow where
  memptyRecord _
    = insert mempty tail
    where
      key = reflectSymbol (Proxy :: Proxy key)
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = memptyRecord (Proxy :: Proxy rowlistTail)

module Data.Monoid
  ( class Monoid, mempty
  , power
  , guard
  , module Data.Semigroup
  , class MonoidRecord, memptyRecord
  ) where

import Data.Boolean (otherwise)
import Data.Eq ((==))
import Data.EuclideanRing (mod, (/))
import Data.Ord ((<=))
import Data.Ordering (Ordering(..))
import Data.Semigroup (class Semigroup, class SemigroupRecord, (<>))
import Data.Symbol (class IsSymbol, reflectSymbol)
import Data.Unit (Unit, unit)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeSet)
import Type.Proxy (Proxy(..))

-- | A `Monoid` is a `Semigroup` with a value `mempty`, which is both a
-- | left and right unit for the associative operation `<>`:
-- |
-- | - Left unit: `(mempty <> x) = x`
-- | - Right unit: `(x <> mempty) = x`
-- |
-- | `Monoid`s are commonly used as the result of fold operations, where
-- | `<>` is used to combine individual results, and `mempty` gives the result
-- | of folding an empty collection of elements.
-- |
-- | ### Newtypes for Monoid
-- |
-- | Some types (e.g. `Int`, `Boolean`) can implement multiple law-abiding
-- | instances for `Monoid`. Let's use `Int` as an example
-- | 1. `<>` could be `+` and `mempty` could be `0`
-- | 2. `<>` could be `*` and `mempty` could be `1`.
-- |
-- | To clarify these ambiguous situations, one should use the newtypes
-- | defined in `Data.Monoid.<NewtypeName>` modules.
-- |
-- | In the above ambiguous situation, we could use `Additive`
-- | for the first situation or `Multiplicative` for the second one.
class Semigroup m <= Monoid m where
  mempty :: m

instance monoidUnit :: Monoid Unit where
  mempty = unit

instance monoidOrdering :: Monoid Ordering where
  mempty = EQ

instance monoidFn :: Monoid b => Monoid (a -> b) where
  mempty _ = mempty

instance monoidString :: Monoid String where
  mempty = ""

instance monoidArray :: Monoid (Array a) where
  mempty = []

instance monoidRecord :: (RL.RowToList row list, MonoidRecord list row row) => Monoid (Record row) where
  mempty = memptyRecord (Proxy :: Proxy list)

-- | Append a value to itself a certain number of times. For the
-- | `Multiplicative` type, and for a non-negative power, this is the same as
-- | normal number exponentiation.
-- |
-- | If the second argument is negative this function will return `mempty`
-- | (*unlike* normal number exponentiation). The `Monoid` constraint alone
-- | is not enough to write a `power` function with the property that `power x
-- | n` cancels with `power x (-n)`, i.e. `power x n <> power x (-n) = mempty`.
-- | For that, we would additionally need the ability to invert elements, i.e.
-- | a Group.
power :: forall m. Monoid m => m -> Int -> m
power x = go
  where
  go :: Int -> m
  go p
    | p <= 0 = mempty
    | p == 1 = x
    | p `mod` 2 == 0 = let x' = go (p / 2) in x' <> x'
    | otherwise = let x' = go (p / 2) in x' <> x' <> x

-- | Allow or "truncate" a Monoid to its `mempty` value based on a condition.
guard :: forall m. Monoid m => Boolean -> m -> m
guard true a = a
guard false _ = mempty

-- | A class for records where all fields have `Monoid` instances, used to
-- | implement the `Monoid` instance for records.
class MonoidRecord :: RL.RowList Type -> Row Type -> Row Type -> Constraint
class SemigroupRecord rowlist row subrow <= MonoidRecord rowlist row subrow | rowlist -> row subrow where
  memptyRecord :: forall rlproxy. rlproxy rowlist -> Record subrow

instance monoidRecordNil :: MonoidRecord RL.Nil row () where
  memptyRecord _ = {}

instance monoidRecordCons
    :: ( IsSymbol key
       , Monoid focus
       , Row.Cons key focus subrowTail subrow
       , MonoidRecord rowlistTail row subrowTail
       )
    => MonoidRecord (RL.Cons key focus rowlistTail) row subrow where
  memptyRecord _
    = insert mempty tail
    where
      key = reflectSymbol (Proxy :: Proxy key)
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = memptyRecord (Proxy :: Proxy rowlistTail)


install initial slides

install initial slides

module UI.Control.Test (tests) where

import Prelude
import Partial.Unsafe (unsafePartial)
import Data.Either (either, fromRight)
import Data.Maybe (Maybe(..))
import Data.Lens
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (equal)
import UI.Event (Event(..))
import Model.Presentation.New (create, Presentation)
import Model.App (newApp, presentation)

import UI.Control (reduce)

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "UI.Control" do
        test "change slides" do
          let event = Content testSource
          let initial = newApp # presentation .~ Just (makePres "# was")
          let actual = reduce event initial
          let expected = newApp # presentation .~ Just testPres
          equal expected actual
        test "install slides" do
          let event = Content testSource
          let initial = newApp
          let actual = reduce event initial
          let expected = newApp # presentation .~ Just testPres
          equal expected actual

makePres :: String -> Presentation
makePres src = unsafePartial $ fromRight $ create src

testPres :: Presentation
testPres = makePres testSource

testSource :: String
testSource = """# Slide 1
---
# Slide 2
---
# Slide 3
---
# Slide 4
---
# Slide 5
"""

module UI.Control.Test (tests) where

import Prelude
import Partial.Unsafe (unsafePartial)
import Data.Either (either, fromRight)
import Data.Maybe (Maybe(..))
import Data.Lens
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (equal)
import UI.Event (Event(..))
import Model.Presentation.New (create, Presentation)
import Model.App (newApp, presentation)

import UI.Control (reduce)

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "UI.Control" do
        test "change slides" do
          let event = Content testSource
          let initial = newApp # presentation .~ Just (makePres "# was")
          let actual = reduce event initial
          let expected = newApp # presentation .~ Just testPres
          equal expected actual

makePres :: String -> Presentation
makePres src = unsafePartial $ fromRight $ create src

testPres :: Presentation
testPres = makePres testSource

testSource :: String
testSource = """# Slide 1
---
# Slide 2
---
# Slide 3
---
# Slide 4
---
# Slide 5
"""


Remove `Printer` module

Remove `Printer` module

module Data.Argonaut.Printer where

import Prelude

import Data.Argonaut.Core (Json)

class Printer a where
  printJson :: Json -> a

instance printerString :: Printer String where
  printJson = show


removing redundant import

removing redundant import

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

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query 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.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleComponent
    { 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 =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

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

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ 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
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]
        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]
        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ 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 $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next
  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next
  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next
  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next
  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next
  StopPropagation e q → do
    H.liftEff $ DOM.stopPropagation e
    eval q
  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

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

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query 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.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleComponent
    { 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 =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

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

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ 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
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]
        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]
        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ 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 $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next
  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next
  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next
  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next
  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next
  StopPropagation e q → do
    H.liftEff $ DEE.stopPropagation e
    eval q
  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

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