Parser now works without stack overflow

Parser now works without stack overflow

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

parsePropertyUpdate :: {} -> P.Parser [L.Token] (Tuple String Value)
parsePropertyUpdate _ = do
  name <- identifier <|> stringLiteral
  value <- equals *> parseValue {}
  return (Tuple name value)

parseAccessor :: Value -> P.Parser [L.Token] Value
parseAccessor (Constructor _) = P.fail "Unexpected constructor"
parseAccessor obj = P.try $ Accessor <$> (dot *> (identifier <|> stringLiteral)) <*> pure obj

-- |
-- Parse a value
--
parseValue :: {} -> P.Parser [L.Token] Value
parseValue _ = P.fix $ \parseValue' ->
  let

    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' ]

    indexersAndAccessors = buildPostfixParser postfixTable1 parseValueAtom

    postfixTable1 = [ parseAccessor
                    , \v -> P.try $ flip ObjectUpdate <$> (braces (commaSep1 (parsePropertyUpdate {}))) <*> pure v
                    ]
    postfixTable2 = [ \v -> P.try (flip App <$> indexersAndAccessors) <*> pure v
                    , \v -> flip (TypedValue true) <$> (doubleColon *> parseType) <*> pure v
                    ]

  in PositionedValue <$> sourcePos
                               <*> (P.buildExprParser operators <<< buildPostfixParser postfixTable2 $ indexersAndAccessors)
                               P.<?> "expression"
  where

  operators = [ [ P.Prefix (P.try (symbol' "-") *> return UnaryMinus)
                ]
              , [ P.Infix (P.try (parseIdentInfix P.<?> "operator") >>= \ident ->
                    return (BinaryNoParens ident)) P.AssocRight
                ]
              ]

parseGuard :: {} -> P.Parser [L.Token] Guard
parseGuard _ = pipe *> parseValue {}

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 _ = 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 {}) ]

parsePropertyUpdate :: {} -> P.Parser [L.Token] (Tuple String Value)
parsePropertyUpdate _ = do
  name <- identifier <|> stringLiteral
  value <- equals *> parseValue {}
  return (Tuple name value)

parseAccessor :: Value -> P.Parser [L.Token] Value
parseAccessor (Constructor _) = P.fail "Unexpected constructor"
parseAccessor obj = P.try $ Accessor <$> (dot *> (identifier <|> stringLiteral)) <*> pure obj

-- |
-- Parse a value
--
parseValue :: {} -> P.Parser [L.Token] Value
parseValue _ = PositionedValue <$> sourcePos
                               <*> (P.buildExprParser operators <<< buildPostfixParser postfixTable2 $ indexersAndAccessors)
                               P.<?> "expression"
  where
  indexersAndAccessors = buildPostfixParser postfixTable1 (parseValueAtom {})
  postfixTable1 = [ parseAccessor
                  , \v -> P.try $ flip ObjectUpdate <$> (braces (commaSep1 (parsePropertyUpdate {}))) <*> pure v
                  ]
  postfixTable2 = [ \v -> P.try (flip App <$> indexersAndAccessors) <*> pure v
                  , \v -> flip (TypedValue true) <$> (doubleColon *> parseType) <*> pure v
                  ]
  operators = [ [ P.Prefix (P.try (symbol' "-") *> return UnaryMinus)
                ]
              , [ P.Infix (P.try (parseIdentInfix P.<?> "operator") >>= \ident ->
                    return (BinaryNoParens ident)) P.AssocRight
                ]
              ]

parseGuard :: {} -> P.Parser [L.Token] Guard
parseGuard _ = pipe *> parseValue {}

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

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


Add toStandardError

Add toStandardError

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , Error()
  , toStandardError
  , Exit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , fork
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind ((>=>))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Data.Posix (Pid())
import Data.Posix.Signal (Signal())
import Data.Posix.Signal as Signal
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Stream (Readable(), Writable(), Stream())

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin      :: forall eff. Nullable (Writable () (cp :: CHILD_PROCESS | eff))
  , stdout     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , stderr     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , pid        :: Pid
  , connected  :: Boolean
  , kill       :: String -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff)
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff)
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS| eff)
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected (ChildProcess cp) = mkEff \_ -> cp.connected

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = mkEff \_ -> runFn2 cp.send msg handle

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = mkEff \_ -> cp.kill (Signal.toString sig)

mkEff :: forall eff a. (Unit -> a) -> Eff eff a
mkEff = unsafeCoerce

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data Exit
  = Normally Int
  | BySignal Signal

instance showExit :: Show Exit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkExit :: Nullable Int -> Nullable String -> Exit
mkExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkExit: Invalid arguments"
  where
  fromCode   = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

onExit :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (Error -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: forall eff. String -> Array String -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type Error =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Convert a ChildProcess.Error to a standard Error, which can then be thrown
-- | inside an Eff or Aff computation (for example).
toStandardError :: Error -> Exception.Error
toStandardError = unsafeCoerce

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff. Stream r eff)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , Error()
  , Exit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , fork
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind ((>=>))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Data.Posix (Pid())
import Data.Posix.Signal (Signal())
import Data.Posix.Signal as Signal
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Stream (Readable(), Writable(), Stream())

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin      :: forall eff. Nullable (Writable () (cp :: CHILD_PROCESS | eff))
  , stdout     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , stderr     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , pid        :: Pid
  , connected  :: Boolean
  , kill       :: String -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff)
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff)
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS| eff)
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected (ChildProcess cp) = mkEff \_ -> cp.connected

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = mkEff \_ -> runFn2 cp.send msg handle

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = mkEff \_ -> cp.kill (Signal.toString sig)

mkEff :: forall eff a. (Unit -> a) -> Eff eff a
mkEff = unsafeCoerce

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data Exit
  = Normally Int
  | BySignal Signal

instance showExit :: Show Exit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkExit :: Nullable Int -> Nullable String -> Exit
mkExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkExit: Invalid arguments"
  where
  fromCode   = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

onExit :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (Error -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: forall eff. String -> Array String -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type Error =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff. Stream r eff)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)


Update completion type signatures to be more indicative

module IdePurescript.PscIde (getCompletion, getCompletion', cwd, loadDeps, getType, eitherToErr
  , getPursuitModuleCompletion, getPursuitCompletion, getAvailableModules, getLoadedModules, SearchResult, ModuleSearchResult
  , getTypeInfo) where

import Prelude
import Control.Monad.Eff.Exception as Ex
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Decode.Combinators ((.?))
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Maybe (maybe, Maybe(..))
import Data.Nullable (toNullable, Nullable)
import Data.String.Regex (regex)
import Data.String.Regex.Flags (global)
import IdePurescript.Regex (replace')
import PscIde.Command (TypePosition)

eitherToErr :: forall a eff. Aff (net :: P.NET | eff) (Either String a) -> (Aff (net :: P.NET | eff) a)
eitherToErr c = do
  r <- c
  case r of
    Left s -> throwError (Ex.error s)
    Right res -> pure res

result :: forall eff a b. (a -> b) ->  Aff (net :: P.NET | eff) (Either String a) -> Aff (net :: P.NET | eff) b
result f a = eitherToErr ((f <$> _) <$> a)

cwd :: forall eff. Int -> Aff (net :: P.NET | eff) String
cwd = result runMsg <<< P.cwd

runMsg :: C.Message -> String
runMsg (C.Message m) = m

getImports' :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array { module :: String, qualifier :: Nullable String })
getImports' port s = result conv $ P.listImports port s
  where
  conv (C.ImportList imps) = conv' <$> imps
  conv' (C.Import {moduleName, qualifier}) = {
    "module": moduleName,
    qualifier: toNullable qualifier
  }

getAvailableModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getAvailableModules = result conv <<< P.listAvailableModules
  where
  conv (C.ModuleList modules) = modules

getLoadedModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getLoadedModules = result conv <<< P.listLoadedModules
  where
  conv (C.ModuleList modules) = modules

abbrevType :: String -> String
abbrevType = replace' r "$1"
  where r = regex """(?:\w+\.)+(\w+)""" $ global

type TypeResult = {type :: String, identifier :: String, module :: String, position :: Maybe TypePosition}

getTypeInfo :: forall eff. Int -> String -> Maybe String -> Maybe String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Maybe C.TypeInfo)
getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule =
  result head $ P.type' port text moduleFilters currentModule
  where
    moduleFilters = [ C.ModuleFilter $ maybe unqualModules getQualifiedModule modulePrefix ]

getType :: forall eff. Int -> String -> Maybe String -> Maybe String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) String
getType port text currentModule modulePrefix unqualModules getQualifiedModule =
  maybe "" getType' <$> getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule
  where
  getType' (C.TypeInfo { type' }) = type'

type CompletionResult = {type :: String, identifier :: String, module :: String}

getCompletion :: forall eff. Int -> String -> Maybe String -> Maybe String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion port prefix =
  getCompletion' Nothing [C.PrefixFilter prefix] port

getCompletion' :: forall eff. Maybe C.Matcher -> Array C.Filter -> Int -> Maybe String -> Maybe String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion' matcher mainFilter port currentModule modulePrefix unqualModules getQualifiedModule =
  eitherToErr $ P.complete port (mainFilter <> moduleFilters) matcher currentModule
  where
  moduleFilters = [ C.ModuleFilter $ maybe unqualModules getQualifiedModule modulePrefix ]

loadDeps :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) String
loadDeps port main = result runMsg $ P.load port [] [main]

type SearchResult = { module :: String, package :: String, type:: Maybe String, identifier :: String, text :: String }

getPursuitCompletion :: forall eff. Int -> String -> Aff (net :: P.NET | eff) (Array SearchResult)
getPursuitCompletion port str = result (map convPursuitCompletion) $ P.pursuitCompletion port str

convPursuitCompletion :: C.PursuitCompletion -> SearchResult
convPursuitCompletion (C.PursuitCompletion { identifier, type', module', package, text })
  = { identifier, package, type: type', module: module', text }

data ModuleCompletion = ModuleCompletion {
  module' :: String,
  package :: String
}

instance decodeModuleCompletion :: DecodeJson ModuleCompletion where
  decodeJson json = do
    o <- decodeJson json
    module' <- o .? "module"
    package <- o .? "package"
    pure (ModuleCompletion {
      module': module',
      package: package
      })

type ModuleSearchResult = { module :: String, package :: String }

getPursuitModuleCompletion :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array ModuleSearchResult)
getPursuitModuleCompletion port str = result (map convPursuitModuleCompletion) $ complete str
  where

  complete :: String -> P.Cmd (Array ModuleCompletion)
  complete q = P.sendCommand port (C.Pursuit C.Package q)

  convPursuitModuleCompletion :: ModuleCompletion -> ModuleSearchResult
  convPursuitModuleCompletion (ModuleCompletion { module', package })
    = { package, module: module' }

module IdePurescript.PscIde (getCompletion, getCompletion', cwd, loadDeps, getType, eitherToErr
  , getPursuitModuleCompletion, getPursuitCompletion, getAvailableModules, getLoadedModules, SearchResult, ModuleSearchResult
  , getTypeInfo) where

import Prelude
import Control.Monad.Eff.Exception as Ex
import Data.String as S
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Decode.Combinators ((.?))
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Maybe (maybe, Maybe(..))
import Data.Nullable (toNullable, Nullable)
import Data.String.Regex (regex)
import Data.String.Regex.Flags (global)
import IdePurescript.Regex (replace')
import PscIde.Command (TypePosition)

eitherToErr :: forall a eff. Aff (net :: P.NET | eff) (Either String a) -> (Aff (net :: P.NET | eff) a)
eitherToErr c = do
  r <- c
  case r of
    Left s -> throwError (Ex.error s)
    Right res -> pure res

result :: forall eff a b. (a -> b) ->  Aff (net :: P.NET | eff) (Either String a) -> Aff (net :: P.NET | eff) b
result f a = eitherToErr ((f <$> _) <$> a)

cwd :: forall eff. Int -> Aff (net :: P.NET | eff) String
cwd = result runMsg <<< P.cwd

runMsg :: C.Message -> String
runMsg (C.Message m) = m

getImports' :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array { module :: String, qualifier :: Nullable String })
getImports' port s = result conv $ P.listImports port s
  where
  conv (C.ImportList imps) = conv' <$> imps
  conv' (C.Import {moduleName, qualifier}) = {
    "module": moduleName,
    qualifier: toNullable qualifier
  }

getAvailableModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getAvailableModules = result conv <<< P.listAvailableModules
  where
  conv (C.ModuleList modules) = modules

getLoadedModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getLoadedModules = result conv <<< P.listLoadedModules
  where
  conv (C.ModuleList modules) = modules

moduleFilterModules :: String -> Array String -> (String -> Array String) -> Array String
moduleFilterModules modulePrefix unqualModules getQualifiedModule =
  if S.null modulePrefix then
    unqualModules
  else
    getQualifiedModule modulePrefix

abbrevType :: String -> String
abbrevType = replace' r "$1"
  where r = regex """(?:\w+\.)+(\w+)""" $ global

type TypeResult = {type :: String, identifier :: String, module :: String, position :: Maybe TypePosition}

getTypeInfo :: forall eff. Int -> String -> Maybe String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Maybe C.TypeInfo)
getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule =
  result head $ P.type' port text moduleFilters currentModule
  where
    moduleFilters = [ C.ModuleFilter $ moduleFilterModules modulePrefix unqualModules getQualifiedModule ]

getType :: forall eff. Int -> String -> Maybe String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) String
getType port text currentModule modulePrefix unqualModules getQualifiedModule =
  maybe "" getType' <$> getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule
  where
  getType' (C.TypeInfo { type' }) = type'

type CompletionResult = {type :: String, identifier :: String, module :: String}

getCompletion :: forall eff. Int -> String -> Maybe String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion port prefix =
  getCompletion' Nothing [C.PrefixFilter prefix] port

getCompletion' :: forall eff. Maybe C.Matcher -> Array C.Filter -> Int -> Maybe String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion' matcher mainFilter port currentModule modulePrefix moduleCompletion unqualModules getQualifiedModule =
  eitherToErr $ P.complete port (mainFilter <> moduleFilters) matcher currentModule
  where
  moduleFilters = if moduleCompletion then [] else [ C.ModuleFilter $ moduleFilterModules modulePrefix unqualModules getQualifiedModule ]

loadDeps :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) String
loadDeps port main = result runMsg $ P.load port [] [main]

type SearchResult = { module :: String, package :: String, type:: Maybe String, identifier :: String, text :: String }

getPursuitCompletion :: forall eff. Int -> String -> Aff (net :: P.NET | eff) (Array SearchResult)
getPursuitCompletion port str = result (map convPursuitCompletion) $ P.pursuitCompletion port str

convPursuitCompletion :: C.PursuitCompletion -> SearchResult
convPursuitCompletion (C.PursuitCompletion { identifier, type', module', package, text })
  = { identifier, package, type: type', module: module', text }

data ModuleCompletion = ModuleCompletion {
  module' :: String,
  package :: String
}

instance decodeModuleCompletion :: DecodeJson ModuleCompletion where
  decodeJson json = do
    o <- decodeJson json
    module' <- o .? "module"
    package <- o .? "package"
    pure (ModuleCompletion {
      module': module',
      package: package
      })

type ModuleSearchResult = { module :: String, package :: String }

getPursuitModuleCompletion :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array ModuleSearchResult)
getPursuitModuleCompletion port str = result (map convPursuitModuleCompletion) $ complete str
  where

  complete :: String -> P.Cmd (Array ModuleCompletion)
  complete q = P.sendCommand port (C.Pursuit C.Package q)

  convPursuitModuleCompletion :: ModuleCompletion -> ModuleSearchResult
  convPursuitModuleCompletion (ModuleCompletion { module', package })
    = { package, module: module' }


Update old operator secions in Applicative laws (#112)

module Control.Applicative
  ( class Applicative, pure
  , liftA1
  , unless, when
  , module Control.Apply
  , module Data.Functor
  ) where

import Control.Apply (class Apply, apply, (*>), (<*), (<*>))

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit, unit)

-- | The `Applicative` type class extends the [`Apply`](#apply) type class
-- | with a `pure` function, which can be used to create values of type `f a`
-- | from values of type `a`.
-- |
-- | Where [`Apply`](#apply) provides the ability to lift functions of two or
-- | more arguments to functions whose arguments are wrapped using `f`, and
-- | [`Functor`](#functor) provides the ability to lift functions of one
-- | argument, `pure` can be seen as the function which lifts functions of
-- | _zero_ arguments. That is, `Applicative` functors support a lifting
-- | operation for any number of function arguments.
-- |
-- | Instances must satisfy the following laws in addition to the `Apply`
-- | laws:
-- |
-- | - Identity: `(pure id) <*> v = v`
-- | - Composition: `pure (<<<) <*> f <*> g <*> h = f <*> (g <*> h)`
-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
-- | - Interchange: `u <*> (pure y) = (pure (_ $ y)) <*> u`
class Apply f <= Applicative f where
  pure :: forall a. a -> f a

instance applicativeFn :: Applicative ((->) r) where
  pure x _ = x

instance applicativeArray :: Applicative Array where
  pure x = [x]

-- | `liftA1` provides a default implementation of `(<$>)` for any
-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
-- | relationship.
-- |
-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftA1
-- | ```
liftA1 :: forall f a b. Applicative f => (a -> b) -> f a -> f b
liftA1 f a = pure f <*> a

-- | Perform a applicative action when a condition is true.
when :: forall m. Applicative m => Boolean -> m Unit -> m Unit
when true m = m
when false _ = pure unit

-- | Perform a applicative action unless a condition is true.
unless :: forall m. Applicative m => Boolean -> m Unit -> m Unit
unless false m = m
unless true _ = pure unit

module Control.Applicative
  ( class Applicative, pure
  , liftA1
  , unless, when
  , module Control.Apply
  , module Data.Functor
  ) where

import Control.Apply (class Apply, apply, (*>), (<*), (<*>))

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit, unit)

-- | The `Applicative` type class extends the [`Apply`](#apply) type class
-- | with a `pure` function, which can be used to create values of type `f a`
-- | from values of type `a`.
-- |
-- | Where [`Apply`](#apply) provides the ability to lift functions of two or
-- | more arguments to functions whose arguments are wrapped using `f`, and
-- | [`Functor`](#functor) provides the ability to lift functions of one
-- | argument, `pure` can be seen as the function which lifts functions of
-- | _zero_ arguments. That is, `Applicative` functors support a lifting
-- | operation for any number of function arguments.
-- |
-- | Instances must satisfy the following laws in addition to the `Apply`
-- | laws:
-- |
-- | - Identity: `(pure id) <*> v = v`
-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
class Apply f <= Applicative f where
  pure :: forall a. a -> f a

instance applicativeFn :: Applicative ((->) r) where
  pure x _ = x

instance applicativeArray :: Applicative Array where
  pure x = [x]

-- | `liftA1` provides a default implementation of `(<$>)` for any
-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
-- | relationship.
-- |
-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftA1
-- | ```
liftA1 :: forall f a b. Applicative f => (a -> b) -> f a -> f b
liftA1 f a = pure f <*> a

-- | Perform a applicative action when a condition is true.
when :: forall m. Applicative m => Boolean -> m Unit -> m Unit
when true m = m
when false _ = pure unit

-- | Perform a applicative action unless a condition is true.
unless :: forall m. Applicative m => Boolean -> m Unit -> m Unit
unless false m = m
unless true _ = pure unit


Send move to pong

Send move to pong

module Pong where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(Just))
import Graphics.Canvas (clearRect, getContext2D, getCanvasElementById, Canvas)
import Graphics.Drawing (render, rectangle, filled, black, fillColor)

newtype PongState = PongState { p1 :: Number
                              , p2 :: Number
                              , bx :: Number
                              , by :: Number
                              , bdirX :: Number
                              , bdirY :: Number}

data Player = One | Two
data Move = Up | Down
data PongCommand = MovePlayer {player :: Player, move :: Move}

initial :: PongState
initial = PongState {p1: 0.0, p2: 0.0, bx: 40.0, by: 40.0, bdirX: 1.0, bdirY: 1.0}

sendCommand :: PongCommand -> PongState -> PongState
sendCommand (MovePlayer {player, move}) (PongState s) = PongState (
  let f = case move of
        Up -> (-)
        Down -> (+)
  in
   case player of
     One -> s {p1 = f s.p1 1.0}
     Two -> s {p2 = f s.p2 1.0})

renderPong :: String -> PongState -> Eff (canvas :: Canvas) Unit
renderPong id (PongState s) =  do
  Just canvas <- getCanvasElementById id
  ctx <- getContext2D canvas
  clearRect ctx {x: 0.0, y: 0.0, w: canvasSize.w, h: canvasSize.h}
  render ctx $
    filled (fillColor black) (rectangle 0.0 s.p1 batSize.w batSize.h)
  render ctx $
    filled (fillColor black) (rectangle (canvasSize.w - batSize.w) s.p2 batSize.w batSize.h)
  return unit

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}

module Pong where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(Just))
import Graphics.Canvas (clearRect, getContext2D, getCanvasElementById, Canvas)
import Graphics.Drawing (render, rectangle, filled, black, fillColor)

newtype PongState = PongState { p1 :: Number
                              , p2 :: Number
                              , bx :: Number
                              , by :: Number
                              , bdirX :: Number
                              , bdirY :: Number}

initial :: PongState
initial = PongState {p1: 0.0, p2: 0.0, bx: 40.0, by: 40.0, bdirX: 1.0, bdirY: 1.0}

renderPong :: String -> PongState -> Eff (canvas :: Canvas) Unit
renderPong id (PongState s) =  do
  Just canvas <- getCanvasElementById id
  ctx <- getContext2D canvas
  clearRect ctx {x: 0.0, y: 0.0, w: canvasSize.w, h: canvasSize.h}
  render ctx $
    filled (fillColor black) (rectangle 0.0 s.p1 batSize.w batSize.h)
  render ctx $
    filled (fillColor black) (rectangle (canvasSize.w - batSize.w) s.p1 batSize.w batSize.h)
  return unit

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}


Add Eq instances for Node/Stuck

Add Eq instances for Node/Stuck

module Lambda.Machine.Node
  ( Node(..)
  , Stuck(..)
  , Closure
  , Env
  , deref
  , define
  , compile
  , instantiate
  , instantiateAt
  , children
  ) where

import Lambda.Prelude

import Data.Array as Array
import Data.List as List
import Lambda.Language.Name (Name)
import Lambda.Language.Nameless (Expression)
import Lambda.Language.Nameless as Nameless
import Lambda.Machine.Address (Address)
import Lambda.Machine.Globals (Globals)
import Lambda.Machine.Globals as Globals
import Lambda.Machine.Heap (Heap)
import Lambda.Machine.Heap as Heap
import Partial.Unsafe (unsafeCrashWith)

-- | Nodes in the graph. Closures contain references to the global
-- | addresses they use as well as their local environment. `Stuck`
-- | nodes cannot be evaluated any further. Pointers are used in
-- | updates.
data Node
  = Apply Address Address
  | Closure Closure
  | Global Name Address
  | Pointer Address
  | Stuck Stuck

type Closure =
  { fvs :: Array Address
  , env :: Env Address
  , name :: Name
  , body :: Expression
  }

derive instance genericNode :: Generic Node _

instance showNode :: Show Node where
  show x = genericShow x

instance eqNode :: Eq Node where
  eq x = genericEq x

-- | Stuck nodes cannot be evaluated any further.
data Stuck
  = StuckVar Name
  | StuckLambda Name Address
  | StuckApply Address Address

derive instance genericStuck :: Generic Stuck _

instance showStuck :: Show Stuck where
  show x = genericShow x

instance eqStuck :: Eq Stuck where
  eq x = genericEq x

-- | Closure environments are lists. Construction is fast; indexing is
-- | slow. Environments should be small enough that it doesn't matter.
type Env = List

-- | Index a closure's environment with the De-Bruijn index in a bound
-- | variable.
deref :: forall a. Show a => Int -> Env a -> a
deref i env = case List.index env i of
  Just a -> a
  Nothing -> unsafeCrashWith $ fold
    [ "Invalid De Bruijn index "
    , show i
    , " in environment "
    , show env
    ]

-- | Add a top-level definition to the `Globals`.
define
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Name
  -> Expression
  -> m Unit
define name expr = Globals.add name \_ ->
  Global name <$> compile expr

-- | Instantiate a closed expression.
compile
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Expression
  -> m Address
compile = instantiate Nil

-- | Instantiate an expression in an environment. This builds a shallow
-- | graph of an expression - shallow because we don't go under lambdas
-- | until they're applied.
instantiate
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Env Address
  -> Expression
  -> m Address
instantiate env = case _ of
  Nameless.Lambda name fvs0 body -> do
    fvs <- traverse Globals.get $ Array.fromFoldable fvs0
    Heap.alloc $ Closure { fvs, env, name, body }
  Nameless.Apply f0 a0 -> do
    a <- instantiate env a0
    f <- instantiate env f0
    Heap.alloc $ Apply f a
  Nameless.Bound i ->
    pure $ deref i env
  Nameless.Free name -> Globals.get name

-- | Instantiate an expression in an environment and overwrite the
-- | given address. Generates fewer pointer chains since we don't
-- | need an indirection.
instantiateAt
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Address
  -> Env Address
  -> Expression
  -> m Unit
instantiateAt target env = case _ of
  Nameless.Lambda name fvs0 body -> do
    fvs <- traverse Globals.get $ Array.fromFoldable fvs0
    Heap.update target $ Closure {fvs, env, name, body}
  Nameless.Apply f0 a0 -> do
    a <- instantiate env a0
    f <- instantiate env f0
    Heap.update target $ Apply f a
  Nameless.Bound i ->
    Heap.update target $ Pointer $ deref i env
  Nameless.Free name -> do
    addr <- Globals.get name
    Heap.update target $ Global name addr

-- | Find all addresses embedded in a `Node`. Used for pointer-chasing
-- | in garbage collection.
children :: Node -> Array Address
children = case _ of
  Apply lhs rhs -> [lhs, rhs]
  Closure {fvs, env} -> fvs <> Array.fromFoldable env
  Global _ addr -> [addr]
  Stuck (StuckVar _) -> []
  Stuck (StuckLambda _ addr) -> [addr]
  Stuck (StuckApply lhs rhs) -> [lhs, rhs]
  Pointer addr -> [addr]

module Lambda.Machine.Node
  ( Node(..)
  , Stuck(..)
  , Closure
  , Env
  , deref
  , define
  , compile
  , instantiate
  , instantiateAt
  , children
  ) where

import Lambda.Prelude

import Data.Array as Array
import Data.List as List
import Lambda.Language.Name (Name)
import Lambda.Language.Nameless (Expression)
import Lambda.Language.Nameless as Nameless
import Lambda.Machine.Address (Address)
import Lambda.Machine.Globals (Globals)
import Lambda.Machine.Globals as Globals
import Lambda.Machine.Heap (Heap)
import Lambda.Machine.Heap as Heap
import Partial.Unsafe (unsafeCrashWith)

-- | Nodes in the graph. Closures contain references to the global
-- | addresses they use as well as their local environment. `Stuck`
-- | nodes cannot be evaluated any further. Pointers are used in
-- | updates.
data Node
  = Apply Address Address
  | Closure Closure
  | Global Name Address
  | Stuck Stuck
  | Pointer Address

type Closure =
  { fvs :: Array Address
  , env :: Env Address
  , name :: Name
  , body :: Expression
  }

derive instance genericNode :: Generic Node _

instance showNode :: Show Node where
  show x = genericShow x

-- | Stuck nodes cannot be evaluated any further.
data Stuck
  = StuckVar Name
  | StuckLambda Name Address
  | StuckApply Address Address

derive instance genericStuck :: Generic Stuck _

instance showStuck :: Show Stuck where
  show x = genericShow x

-- | Closure environments are lists. Construction is fast; indexing is
-- | slow. Environments should be small enough that it doesn't matter.
type Env = List

-- | Index a closure's environment with the De-Bruijn index in a bound
-- | variable.
deref :: forall a. Show a => Int -> Env a -> a
deref i env = case List.index env i of
  Just a -> a
  Nothing -> unsafeCrashWith $ fold
    [ "Invalid De Bruijn index "
    , show i
    , " in environment "
    , show env
    ]

-- | Add a top-level definition to the `Globals`.
define
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Name
  -> Expression
  -> m Unit
define name expr = Globals.add name \_ ->
  Global name <$> compile expr

-- | Instantiate a closed expression.
compile
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Expression
  -> m Address
compile = instantiate Nil

-- | Instantiate an expression in an environment. This builds a shallow
-- | graph of an expression - shallow because we don't go under lambdas
-- | until they're applied.
instantiate
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Env Address
  -> Expression
  -> m Address
instantiate env = case _ of
  Nameless.Lambda name fvs0 body -> do
    fvs <- traverse Globals.get $ Array.fromFoldable fvs0
    Heap.alloc $ Closure { fvs, env, name, body }
  Nameless.Apply f0 a0 -> do
    a <- instantiate env a0
    f <- instantiate env f0
    Heap.alloc $ Apply f a
  Nameless.Bound i ->
    pure $ deref i env
  Nameless.Free name -> Globals.get name

-- | Instantiate an expression in an environment and overwrite the
-- | given address. Generates fewer pointer chains since we don't
-- | need an indirection.
instantiateAt
  :: forall s m
   . MonadState { heap :: Heap Node, globals :: Globals | s } m
  => Address
  -> Env Address
  -> Expression
  -> m Unit
instantiateAt target env = case _ of
  Nameless.Lambda name fvs0 body -> do
    fvs <- traverse Globals.get $ Array.fromFoldable fvs0
    Heap.update target $ Closure {fvs, env, name, body}
  Nameless.Apply f0 a0 -> do
    a <- instantiate env a0
    f <- instantiate env f0
    Heap.update target $ Apply f a
  Nameless.Bound i ->
    Heap.update target $ Pointer $ deref i env
  Nameless.Free name -> do
    addr <- Globals.get name
    Heap.update target $ Global name addr

-- | Find all addresses embedded in a `Node`. Used for pointer-chasing
-- | in garbage collection.
children :: Node -> Array Address
children = case _ of
  Apply lhs rhs -> [lhs, rhs]
  Closure {fvs, env} -> fvs <> Array.fromFoldable env
  Global _ addr -> [addr]
  Stuck (StuckVar _) -> []
  Stuck (StuckLambda _ addr) -> [addr]
  Stuck (StuckApply lhs rhs) -> [lhs, rhs]
  Pointer addr -> [addr]


Better word separation

Better word separation

Original commit 47b3b976015fddefadc8e1644f75b01e2c5095a8

module Data.String.Util
    ( plural
    , singular
    , capitalize
    , camelCase
    , intToHex
    , stringEscape
    ) where

import Prelude

import Data.Array as A
import Data.Char (toCharCode)
import Data.Char.Unicode (isPrint)
import Data.Either as Either
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Data.String as S
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Partial.Unsafe (unsafePartial)

foreign import _plural :: String -> String
foreign import _singular :: String -> String

plural :: String -> String
plural = _plural

singular :: String -> String
singular = _singular

capitalize :: String -> String
capitalize "" = ""
capitalize s = case S.uncons s of
    Just { head, tail } -> S.toUpper (S.singleton head) <> tail
    _ -> s

wordSeparatorRegex :: Rx.Regex
wordSeparatorRegex = unsafePartial $ Either.fromRight $ Rx.regex "[-_. ]" RxFlags.noFlags

camelCase :: String -> String
camelCase = Rx.split wordSeparatorRegex >>> map capitalize >>> S.joinWith ""

intToHex :: Int -> Int -> String
intToHex width number =
    let arr = S.toCharArray $ Int.toStringAs Int.hexadecimal number
        len = A.length arr
        fullArr = if len < width then A.replicate (width - len) '0' <> arr else arr
    in
        S.fromCharArray fullArr

stringEscape :: String -> String
stringEscape str =
    S.fromCharArray $ A.concatMap charRep $ S.toCharArray str
    where
        charRep c =
            case c of
            '\\' -> ['\\', '\\']
            '\"' -> ['\\', '\"']
            '\n' -> ['\\', 'n']
            '\t' -> ['\\', 't']
            _ ->
                if isPrint c then
                    [c]
                else
                    let i = toCharCode c
                    in
                        if i <= 0xffff then
                            S.toCharArray $ "\\u" <> intToHex 4 i
                        else
                            S.toCharArray $ "\\U" <> intToHex 8 i

module Data.String.Util
    ( plural
    , singular
    , capitalize
    , camelCase
    , intToHex
    , stringEscape
    ) where

import Prelude

import Data.Array as A
import Data.Char (toCharCode)
import Data.Char.Unicode (isPrint)
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Data.String as S

foreign import _plural :: String -> String
foreign import _singular :: String -> String

plural :: String -> String
plural = _plural

singular :: String -> String
singular = _singular

capitalize :: String -> String
capitalize "" = ""
capitalize s = case S.uncons s of
    Just { head, tail } -> S.toUpper (S.singleton head) <> tail
    _ -> s

camelCase :: String -> String
camelCase = S.split (S.Pattern "_") >>> map capitalize >>> S.joinWith ""

intToHex :: Int -> Int -> String
intToHex width number =
    let arr = S.toCharArray $ Int.toStringAs Int.hexadecimal number
        len = A.length arr
        fullArr = if len < width then A.replicate (width - len) '0' <> arr else arr
    in
        S.fromCharArray fullArr

stringEscape :: String -> String
stringEscape str =
    S.fromCharArray $ A.concatMap charRep $ S.toCharArray str
    where
        charRep c =
            case c of
            '\\' -> ['\\', '\\']
            '\"' -> ['\\', '\"']
            '\n' -> ['\\', 'n']
            '\t' -> ['\\', 't']
            _ ->
                if isPrint c then
                    [c]
                else
                    let i = toCharCode c
                    in
                        if i <= 0xffff then
                            S.toCharArray $ "\\u" <> intToHex 4 i
                        else
                            S.toCharArray $ "\\U" <> intToHex 8 i


Fix the generated embed URL so vars are preserved (#980)

Also don't send `?stylesheets=` unless the array has some content
specified.

{-
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.Deck.Dialog.Export.Component where

import SlamData.Prelude

import Control.Monad.Eff.Ref (Ref, newRef, readRef, writeRef)
import Control.UI.Browser (select, locationString)
import Control.UI.ZClipboard as Z

import Data.Foldable as F
import Data.Map as Map
import Data.Path.Pathy as Pathy
import Data.String as Str
import Data.String.Regex as RX
import Data.StrMap as SM

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.CustomProps as CP
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils (raise)

import OIDCCryptUtils as OIDC

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Security as Q
import SlamData.Render.Common (glyph, fadeWhen)
import SlamData.Render.CSS as Rc
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Deck.Component.State (deckPath')
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString)
import SlamData.Workspace.Deck.Dialog.Share.Model (sharingActions, ShareResume(..), SharingInput)
import SlamData.Workspace.Routing (mkWorkspaceHash, varMapsForURL, encodeVarMaps)

import Quasar.Advanced.Types as QTA

import Utils (prettyJson)
import Utils.Path as UP

data PresentAs = IFrame | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Slam

type State =
  { presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map DeckId Port.VarMap
  , sharingInput ∷ SharingInput
  , permToken ∷ Maybe QTA.TokenR
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLoggedIn ∷ Boolean
  , copyRef ∷ Maybe (Ref String)
  , copyVal ∷ String
  , errored ∷ Boolean
  , submitting ∷ Boolean
  , loading ∷ Boolean
  }

initialState ∷ SharingInput → State
initialState =
  { presentingAs: URI
  , varMaps: Map.empty
  , sharingInput: _
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: false
  , hovered: false
  , isLoggedIn: false
  , copyRef: Nothing
  , copyVal: ""
  , errored: false
  , submitting: false
  , loading: true
  }

data Query a
  = SelectElement HTMLElement a
  | Init (Maybe HTMLElement) a
  | Dismiss a
  | Revoke a
  | ToggleShouldGenerateToken a
  | TextAreaHovered a
  | TextAreaLeft a

comp ∷ H.Component State Query Slam
comp = H.component { render, eval }

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishURI state
  | otherwise = renderPublishIFrame state

renderPublishURI ∷ State → H.ComponentHTML Query
renderPublishURI state =
  HH.div [ HP.classes [ HH.className "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Publish deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.className "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.p_ message
        , HH.form
            [ CP.nonSubmit ]
            [ HH.div
                [ HP.classes [ B.inputGroup ] ]
                $ [ HH.input
                    [ HP.classes [ B.formControl ]
                    , HP.value state.copyVal
                    , HP.readonly true
                    , HP.disabled state.submitting
                    , HP.title "Published deck URL"
                    , ARIA.label "Published deck URL"
                    , HE.onClick \e →
                        HEH.stopPropagation
                          $> (guard (not state.submitting)
                              $> (H.action (SelectElement e.target)))
                    ]
                  , HH.span
                      [ HP.classes [ B.inputGroupBtn ] ]
                      [ HH.button
                        [ HP.classes [ B.btn, B.btnDefault ]
                        , HE.onClick (HE.input_ Dismiss)
                        , HP.ref (H.action ∘ Init)
                        , HP.id_ "copy-button"
                        , HP.buttonType HP.ButtonButton
                        , HP.disabled state.submitting
                        ]
                        [ glyph B.glyphiconCopy ]
                      ]
                  ]
            ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.errored then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ Dismiss)
              , HP.buttonType HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $>  HH.button
                 [ HP.classes [ B.btn, B.btnInfo ]
                 , HE.onClick (HE.input_ Revoke)
                 , ARIA.label "Revoke access to this deck"
                 , HP.title "Revoke access to this deck"
                 , HP.buttonType HP.ButtonButton
                 , HP.enabled $ state.canRevoke ∧ not state.submitting
                 ]
                 [ HH.text "Revoke" ])
        ⊕ [ HH.a
              ( [ HP.classes
                    $ [ B.btn, B.btnPrimary ]
                    ⊕ if state.submitting then [ B.disabled ] else [ ]
                , HP.target "_blank"
                ]
                ⊕ if state.submitting then [ ] else [ HP.href state.copyVal ]
              )
              [ HH.text "Preview" ]
          ]
      ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
          $ "Anyone has access to the following link "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this link may be able to view this deck. "
            ⊕ "They may also be able to modify the link to view or edit any deck "
            ⊕ "in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target  "_blank"
               ]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

renderPublishIFrame ∷ State → H.ComponentHTML Query
renderPublishIFrame state =
  HH.div [ HP.classes [ HH.className "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text  "Embed deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.className "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.form
          [ CP.nonSubmit
          , HE.onMouseOver (HE.input_ TextAreaHovered)
          , HE.onMouseOut (HE.input_ TextAreaLeft)
          ]
          [ HH.div
              [ HP.classes [ B.formGroup ] ]
                [ HH.textarea
                  [ HP.classes [ B.formControl, Rc.embedBox ]
                  , HP.readonly true
                  , HP.value state.copyVal
                  , HE.onClick \e →
                      HEH.stopPropagation
                        $> (guard (not state.submitting)
                            $> (H.action (SelectElement e.target)))
                  ]
                , HH.button
                  [ HP.id_ "copy-button"
                  , HP.classes
                      $ [ B.btn, B.btnDefault, B.btnXs ]
                      ⊕ [ HH.className "textarea-copy-button" ]
                      ⊕ fadeWhen (not state.hovered)
                  , HP.ref (H.action ∘ Init)
                  , HP.buttonType HP.ButtonButton
                  , HP.disabled state.submitting
                  ]
                  [ glyph B.glyphiconCopy ]
                , HH.div [ HP.classes [ B.checkbox ] ]
                  [ (if state.isLoggedIn then HH.label_ else HH.p_)
                    $ ((guard state.isLoggedIn)
                       $> HH.input
                           [ HP.inputType HP.InputCheckbox
                           , HP.checked state.shouldGenerateToken
                           , HP.disabled state.submitting
                           , HE.onChecked (HE.input_ ToggleShouldGenerateToken)
                           ])
                    ⊕ message
                  ]
                ]
          ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.errored then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ Dismiss)
              , HP.buttonType HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $> HH.button
                [ HP.classes [ B.btn, B.btnInfo ]
                , HE.onClick (HE.input_ Revoke)
                , HP.title "Revoke access to this deck"
                , ARIA.label "Revoke access to this deck"
                , HP.buttonType HP.ButtonButton
                , HP.enabled $ state.canRevoke ∧ not state.submitting
                ]
                [ HH.text "Revoke" ])

        ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
            $ "Include a permission token so the deck "
            ⊕ "can be accessed by anyone who has the access to this script. "
            ⊕ "You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this script may be able to view this deck. "
            ⊕ "They may also be able to modify the script to view or edit any "
            ⊕ "deck in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target "_blank"]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

eval ∷ Query ~> DSL
eval (Dismiss next) = pure next
eval (Init mbEl next) = next <$ do
  state ← H.get

  copyRef ← H.fromEff $ newRef ""
  H.modify _{copyRef = Just copyRef}

  for_ mbEl \htmlEl →
    H.fromEff
    $ Z.make (htmlElementToElement htmlEl)
    >>= Z.onCopy \z → do
      val ← readRef copyRef
      Z.setData "text/plain" val z

  -- To know if user is authed
  mbAuthToken ← H.fromEff Auth.retrieveIdToken
  case mbAuthToken of
    Nothing →
      H.modify _{ permToken = Nothing
                , canRevoke = false
                , isLoggedIn = false
                , loading = false
                }
    Just oidcToken → do
      H.modify _{isLoggedIn = true, canRevoke = true}
      tokensRes ← Q.tokenList
      H.modify _{loading = false}
      case tokensRes of
        Left _ → H.modify _{errored = true}
        Right tokens →
          let
            tokenName =
              Just $ workspaceTokenName state.sharingInput.workspacePath oidcToken
            oldToken =
              F.find (\x → x.name ≡ tokenName) tokens
          in case oldToken of
            Just token → do
              H.modify _{ permToken = Just token
                        , errored = false
                        }
            Nothing → do
              isURI ← (_ ≡ URI) <$> H.gets _.presentingAs
              when (state.shouldGenerateToken ∨ isURI) do
                H.modify _{submitting = true}
                createdRes ←
                  Q.createToken
                    tokenName
                    (sharingActions state.sharingInput View)
                H.modify _{submitting = false}
                H.modify case createdRes of
                  Left _ →  _{errored = true}
                  Right newToken →
                     _{ errored = false
                      , permToken = Just newToken
                      }
  updateCopyVal

eval (SelectElement el next) = next <$ H.fromEff (select el)
eval (Revoke next) = do
  mbPermToken ← H.gets _.permToken
  for_ mbPermToken \tok → do
    H.modify _{submitting = true}
    deleteRes ← Q.deleteToken tok.id
    H.modify _{submitting = false}
    case deleteRes of
      Left _ → H.modify _{ errored = true }
      Right _ → raise $ Dismiss unit
  pure next

eval (ToggleShouldGenerateToken next) = next <$ do
  state ← H.get
  case state.permToken of
    Nothing →
      unless state.shouldGenerateToken do
        mbOIDC ← H.fromEff Auth.retrieveIdToken
        workspacePath ← H.gets (_.workspacePath ∘ _.sharingInput)
        for_ mbOIDC \oidc → do
          let
            actions = sharingActions state.sharingInput View
            tokenName = Just $ workspaceTokenName workspacePath oidc
          H.modify _{submitting = true}
          recreatedRes ← Q.createToken tokenName actions
          H.modify _{submitting = false}
          H.modify case recreatedRes of
            Left _ →
              _ { permToken = Nothing
                , errored = true
                }
            Right token →
              _ { permToken = Just token
                , errored = false
                }
    Just tok → do
      H.modify _{submitting = true}
      deleteRes ← Q.deleteToken tok.id
      H.modify _{submitting = false}
      H.modify case deleteRes of
        Left _ → _ { errored = true }
        Right _ → _ { errored = false, permToken = Nothing }
  H.modify _{shouldGenerateToken = not state.shouldGenerateToken}
  updateCopyVal
eval (TextAreaHovered next) =
  next <$ H.modify _{hovered = true}
eval (TextAreaLeft next) =
  next <$ H.modify _{hovered = false}

workspaceTokenName ∷ UP.DirPath → OIDC.IdToken → QTA.TokenName
workspaceTokenName workspacePath token =
  let
    email =
      fromMaybe "unknown user"
        $ map OIDC.runEmail
        $ OIDC.pluckEmail token
    workspace = Pathy.printPath workspacePath
  in
    QTA.TokenName
      $ "publish permission granted by "
      ⊕ email
      ⊕ " for "
      ⊕ workspace

updateCopyVal ∷ DSL Unit
updateCopyVal = do
  locString ← H.fromEff locationString
  state ← H.get
  let
    copyVal = renderCopyVal locString state

  H.modify _{ copyVal = copyVal }
  H.fromEff $ for_ state.copyRef \r → writeRef r copyVal

renderCopyVal ∷ String → State → String
renderCopyVal locString state
  | state.presentingAs ≡ URI =
    renderURL locString state
  | otherwise
      = Str.joinWith "\n"
      [ """"""
      , """"""
      , """"""
      , ""
      , """"""
      , """

"""
      , ""
      , """"""
      , """"""
      ]

    where
    line = (_ ⊕ "\n")
    quoted s = "\"" ⊕ s ⊕ "\""
    workspaceURL = locString ⊕ "/" ⊕ Config.workspaceUrl
    deckId = deckIdToString state.sharingInput.deckId
    deckPath = UP.encodeURIPath (Pathy.printPath state.sharingInput.workspacePath)
    options = opt varMaps <> opt tokens
    opt = case _ of
      "" -> ""
      s -> ",\n" ⊕ s
    varMaps
      | F.all SM.isEmpty state.varMaps = ""
      | otherwise
          = line "    // The variables for the deck(s), you can change their values here:"
          ⊕ "    vars: " ⊕ renderVarMaps state.varMaps
    tokens
      | not state.isLoggedIn = ""
      | otherwise
          = "    permissionTokens: "
          ⊕ "["
          ⊕ maybe
              "window.SLAMDATA_PERMISSION_TOKEN"
              (quoted ∘ QTA.runTokenHash)
              (_.secret <$> state.permToken)
          ⊕ "]"

renderVarMaps ∷ Map.Map DeckId Port.VarMap → String
renderVarMaps = indent <<< prettyJson <<< encodeVarMaps <<< varMapsForURL
  where
  indent = RX.replace (RX.regex "(\n\r?)" (RX.noFlags { global = true })) "$1    "

renderURL ∷ String → State → String
renderURL locationString state@{sharingInput, varMaps, permToken, isLoggedIn} =
  locationString
  ⊕ "/"
  ⊕ Config.workspaceUrl
  ⊕ foldMap
      (append "?permissionTokens=" ∘ QTA.runTokenHash)
      (do guard isLoggedIn
          token ← permToken
          pure token.secret)
  ⊕ mkWorkspaceHash (deckPath' sharingInput.workspacePath sharingInput.deckId) (WA.Load AT.ReadOnly) Map.empty