Added gDefaultEncodeURLPiece for full encoding.

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Util (stripModulePath)
import Data.Array (null)
import Data.Either (Either)
import Data.Generic (class Generic, GenericSpine(SArray, SChar, SString, SNumber, SInt, SBoolean, SRecord, SProd, SUnit), toSpine)
import Data.String (joinWith)
import Global (encodeURIComponent)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

-- | Just use the robust JSON format.
gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = show <<< Aeson.encodeJson

-- | Full encoding based on gDefaultToURLPiece
gDefaultEncodeURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultEncodeURLPiece = encodeURIComponent <<< gDefaultToURLPiece

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : gDefaultToURLPiece
  , params : params
}

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Util (stripModulePath)
import Data.Array (null)
import Data.Either (Either)
import Data.Generic (class Generic, GenericSpine(SArray, SChar, SString, SNumber, SInt, SBoolean, SRecord, SProd, SUnit), toSpine)
import Data.String (joinWith)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

-- Just use the robust JSON format.
gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = show <<< Aeson.encodeJson

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : gDefaultToURLPiece
  , params : params
}


Changed toURLPiece to just use JSON

Changed toURLPiece to just use JSON

Screw readability: For JSON we have compatible encoding/decoding for
server and the client. I don't want to invent yet another format which
has to be compatible.

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Util (stripModulePath)
import Data.Array (null)
import Data.Either (Either)
import Data.Generic (class Generic, GenericSpine(SArray, SChar, SString, SNumber, SInt, SBoolean, SRecord, SProd, SUnit), toSpine)
import Data.String (joinWith)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

-- Just use the robust JSON format.
gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = show <<< Aeson.encodeJson

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : gDefaultToURLPiece
  , params : params
}

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude

import Data.Argonaut.Core (Json())
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Generic.Util (stripModulePath)
import Data.Generic (class Generic, GenericSpine(SArray, SChar, SString, SNumber, SInt, SBoolean, SRecord, SProd, SUnit), toSpine)
import Data.Either (Either)
import Data.Array (null)
import Data.String (joinWith)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = gToURLPiece <<< toSpine
  where
    gToURLPiece :: GenericSpine -> String
    gToURLPiece (SProd s arr) = genericShowPrec 0 $ SProd (stripModulePath s) arr
    gToURLPiece s = genericShowPrec 0 s

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : show <<< Aeson.encodeJson -- Just use the robust JSON format.
  , params : params
}

genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr) =
    if null arr
    then s
    else showParen (d > 10) $ s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (x unit)) arr)
  where showParen false x = x
        showParen true  x = "(" <> x <> ")"

genericShowPrec d (SRecord xs) = "{" <> joinWith ", " (map (\x -> x.recLabel <> ": " <> genericShowPrec 0 (x.recValue unit)) xs) <> "}"
genericShowPrec d (SBoolean x) = show x
genericShowPrec d (SInt x)     = show x
genericShowPrec d (SNumber x)  = show x
genericShowPrec d (SString x)  = show x
genericShowPrec d (SChar x)    = show x
genericShowPrec d (SArray xs)  = "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (x unit)) xs) <> "]"
genericShowPrec d SUnit        = show unit


forgot about decodeURIComponent

forgot about decodeURIComponent

module Routing.Parser (
  parse
  ) where

import Control.MonadPlus
import Data.Maybe
import Data.Tuple
import Data.Traversable (traverse)
import qualified Data.StrMap as M
import qualified Data.String as S
import qualified Data.Array as A

import Routing.Types

tryQuery :: RoutePart -> RoutePart
tryQuery source@(Path string) = fromMaybe source $ do
  guard $ S.take 1 string == "?"
  let parts = S.split "&" $ S.drop 1 string
  Query <$> M.fromList <$> traverse part2tuple parts
  where part2tuple :: String -> Maybe (Tuple String String)
        part2tuple input = do
          let keyVal = S.split "=" input
          guard $ A.length keyVal <= 2
          Tuple <$> (A.head keyVal) <*> (keyVal A.!! 1)
tryQuery q = q

foreign import decodeURIComponent :: String -> String

parse :: String -> Route
parse hash = tryQuery <$> Path <$> decodeURIComponent <$> S.split "/" hash

module Routing.Parser (
  parse
  ) where

import Control.MonadPlus
import Data.Maybe
import Data.Tuple
import Data.Traversable (traverse)
import qualified Data.StrMap as M
import qualified Data.String as S
import qualified Data.Array as A

import Routing.Types

tryQuery :: RoutePart -> RoutePart
tryQuery source@(Path string) = fromMaybe source $ do
  guard $ S.take 1 string == "?"
  let parts = S.split "&" $ S.drop 1 string
  Query <$> M.fromList <$> traverse part2tuple parts
  where part2tuple :: String -> Maybe (Tuple String String)
        part2tuple input = do
          let keyVal = S.split "=" input
          guard $ A.length keyVal <= 2
          Tuple <$> (A.head keyVal) <*> (keyVal A.!! 1)
tryQuery q = q

parse :: String -> Route
parse hash = tryQuery <$> Path <$> S.split "/" hash


[WIP] Start using websocket-simple for connecting with the core

module State where

import Prelude
import Types
import Data.Array
import Data.Lens
import Data.Lens.Index
import Data.Lens.Setter
import Data.Array
import Data.Maybe
import Data.Argonaut
import Control.Monad.Aff
import Control.Monad.Eff
import Data.String as S
import Control.Monad.Eff.Class (liftEff)
import Data.Lens.Traversal (traversed)
import Pux (noEffects)

initialNotebook :: Notebook
initialNotebook = Notebook
  { title: ""
  , subtitle: ""
  , author: ""
  , date: ""
  , cells: [] :: Array Cell
  }

initialAppState :: AppState
initialAppState = AppState
  { editing: true
  , notebook: initialNotebook
  , totalCells: 0
  , currentCell: 0
  }

appendCell :: Cell -> AppState -> AppState
appendCell c =
  ((_notebook <<< _cells ) <>~ [c]) <<< (_totalCells +~ 1)

addTextCell :: AppState -> AppState
addTextCell as = appendCell (Cell { cellId : (getTotalCells as), cellContent: "Type here", cellType: TextCell} ) as

addCodeCell :: AppState -> AppState
addCodeCell as = appendCell emptyCodeCell as
  where
    emptyCodeCell = Cell { cellId : (getTotalCells as), cellContent: "Type here", cellType: CodeCell }

getTotalCells = view _totalCells

updateCell :: Int -> String -> AppState -> AppState
updateCell i s =
  over (_notebook <<< _cells) (\x -> map updateCell' x)
  where
    isCorrectCell (Cell c) = c.cellId == i
    updateCell' (Cell c) = if isCorrectCell (Cell c) then Cell c { cellContent = s } else Cell c

update :: Action -> AppState -> EffModel AppState Action (makeEditor :: MAKEEDITOR, websocket :: WEBSOCKET)
update ToggleEdit appState  = noEffects $ appState
update AddTextCell appState = noEffects $ addTextCell appState
update AddCodeCell appState = noEffects $ addCodeCell appState
update (RenderCodeCell i) appState =
  { state: appState
  , effects: [ do
      liftEff $ makeEditor i
      pure NoOp
    ]
  }
update (CheckInput i ev) appState = noEffects $ updateCell i ev.target.value appState
update CheckNotebook as@(AppState appState) =
    { state: as
    , effects: [ do
        liftEff $ checkNotebook appState.notebook
        pure NoOp
      ]
    }
update NoOp appState = noEffects $ appState

checkNotebook :: forall eff . Notebook -> Eff ( websocket :: WEBSOCKET | eff ) Action
checkNotebook n = checkNotebookImpl $ encodeJson n

foreign import data MAKEEDITOR :: !
foreign import makeEditor :: forall eff. Int -> Eff ( makeEditor :: MAKEEDITOR | eff ) Action

foreign import data WEBSOCKET :: !
foreign import checkNotebookImpl :: forall eff. Json -> Eff ( websocket :: WEBSOCKET | eff ) Action


Added free monad interpretation.

Added free monad interpretation.

module Graphics.WebGL.Free (
	WebGL(),
	WebGLF()
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Free
import Graphics.Canvas (Canvas())
import qualified Graphics.WebGL.Raw as R
import Graphics.WebGL.Raw.Types

data WebGLF a
	= Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| DepthFunc GLenum a
	| Enable GLenum a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

clear :: GLbitfield -> WebGL Unit
clear mask = liftF $ Clear mask unit

clearColor :: GLclampf -> GLclampf -> GLclampf -> GLclampf -> WebGL Unit
clearColor r g b a = liftF $ ClearColor r g b a unit

depthFunc :: GLenum -> WebGL Unit
depthFunc func = liftF $ DepthFunc func unit

enable :: GLenum -> WebGL Unit
enable cap = liftF $ Enable cap unit

viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
viewport x y w h = liftF $ Viewport x y w h unit

runWebGL :: forall a eff. R.WebGLContext -> WebGL a -> Eff (canvas :: Canvas | eff) a
runWebGL gl = runFreeM interpret
	where
	interpret :: WebGLF (WebGL a) -> Eff (canvas :: Canvas | eff) a
	interpret (Clear mask rest) = do
		R.clear gl mask
		return rest
	interpret (ClearColor r g b a rest) = do
		R.clearColor gl r g b a
		return rest
	interpret (DepthFunc func rest) = do
		R.depthFunc gl func
		return rest
	interpret (Enable cap) = do
		R.enable gl cap
		return rest
	interpret (Viewport x y w h rest) = do
		R.viewport gl x y w h
		return rest

module Graphics.WebGL.Free (
	WebGL(),
	WebGLF()
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Free
import Graphics.Canvas (Canvas())
import qualified Graphics.WebGL.Raw as GL
import Graphics.WebGL.Raw.Types

data WebGLF a
	= Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| DepthFunc GLenum a
	| Enable GLenum a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

--viewport :: forall eff. WebGLContext -> GLint -> GLint -> GLsizei -> GLsizei- -> Eff (canvas :: Canvas | eff) Unit
--viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
--viewport = liftF $ Viewport


removed Data.List from API defs

removed Data.List from API defs

module API.PouchDB
          (
              PouchDBM
            , PouchDB
            , PouchDBEff
            , Adapter(..)
            , StorageType(..)
            , AndroidDBImplementation(..)
            , PouchDBOptions(..)
            , PouchDBInfo(..)
            , PouchDBResponse(..)
            , PouchDBDocument(..)
            , logRaw
            , pouchDB
            , info
            , destroy
            , put
            , post
            , get
            , remove
            , removeDocRev
            , allDocs
            , bulkDocs
          ) where

import Prelude                       (Unit)
import Data.Maybe                    (Maybe)
import Control.Monad.Eff             (Eff)
import Control.Monad.Eff.Console     (CONSOLE())
import Control.Monad.Eff.Exception   (EXCEPTION)

-- | PouchDB Effects & Types
foreign import data PouchDBM :: !
foreign import data PouchDB  :: *

type PouchDBEff a = forall e. Eff(pouchDBM :: PouchDBM | e) a

data Adapter = IDB | LevelDB | WebSQL | Http
data StorageType = Persistent | Temporary
data AndroidDBImplementation = SQLite4Java | NativeAPI

data PouchDBResponse a = PouchDBResponse a |
          SimpleResponse {
            "ok" :: Boolean
          }

data PouchDBOptions a =
            DefaultDBOptions {
              "name" :: String
            }
          | LocalDBOptions {
              "auto_compaction" :: Boolean,
              "adapter"         :: Adapter,
              "revs_limit"      :: Int
            }
          | RemoteDBOptions {
              "ajax.cache"           :: Boolean,
              "ajax.headers"         :: Array String,
              "auth.username"        :: String,
              "auth.password"        :: String,
              "ajax.withCredentials" :: Boolean
            }
          | IndexedDBOptions {
              "storage" :: StorageType
            }
          | WebSQLOptions {
              "size" :: Int
            }
          | OtherDBOptions a

data PouchDBDocument a = PouchDBDocument {
                          "_id"   :: Maybe String,
                          "_rev"  :: Maybe String
                          | a
                        }

data PouchDBInfo = PouchDBInfo {
  "db_name"    :: String,
  "doc_count"  :: Number,
  "update_seq" :: Number
}

-- | Logging helper
foreign import logRaw :: forall a e. a -> Eff (console :: CONSOLE | e) Unit

-- | PouchDB API
foreign import pouchDB      :: forall a e. Maybe String -> Maybe (PouchDBOptions a) -> Eff (err :: EXCEPTION | e) PouchDB
foreign import info         :: forall a e f. Maybe (a -> Eff e Unit) -> PouchDB -> Eff (err :: EXCEPTION | f) Unit
foreign import destroy      :: forall a b c e. Maybe (PouchDBOptions a) -> Maybe (b -> Eff c Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import put          :: forall a b c d e. PouchDBDocument a -> Maybe String -> Maybe String -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import post         :: forall a b c d e. PouchDBDocument a -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import get          :: forall a b c e. String -> Maybe (PouchDBOptions a) -> Maybe (b -> Eff c Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import remove       :: forall a b c d e. PouchDBDocument a -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import removeDocRev :: forall a b c d e. PouchDBDocument a -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import bulkDocs     :: forall a b c d e. Array (PouchDBDocument a) -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import allDocs      :: forall a b c e. Maybe (PouchDBOptions a) -> Maybe(b -> Eff c Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit

module API.PouchDB
          (
              PouchDBM
            , PouchDB
            , PouchDBEff
            , Adapter(..)
            , StorageType(..)
            , AndroidDBImplementation(..)
            , PouchDBOptions(..)
            , PouchDBInfo(..)
            , PouchDBResponse(..)
            , PouchDBDocument(..)
            , logRaw
            , pouchDB
            , info
            , destroy
            , put
            , post
            , get
            , remove
            , removeDocRev
            , allDocs
            , bulkDocs
          ) where

import Prelude                       (Unit)
import Data.Maybe                    (Maybe)
import Data.List                     (List)
import Control.Monad.Eff             (Eff)
import Control.Monad.Eff.Console     (CONSOLE())
import Control.Monad.Eff.Exception   (EXCEPTION)

-- | PouchDB Effects & Types
foreign import data PouchDBM :: !
foreign import data PouchDB  :: *

type PouchDBEff a = forall e. Eff(pouchDBM :: PouchDBM | e) a

data Adapter = IDB | LevelDB | WebSQL | Http
data StorageType = Persistent | Temporary
data AndroidDBImplementation = SQLite4Java | NativeAPI

data PouchDBResponse a = PouchDBResponse a |
          SimpleResponse {
            "ok" :: Boolean
          }

data PouchDBOptions a =
            DefaultDBOptions {
              "name" :: String
            }
          | LocalDBOptions {
              "auto_compaction" :: Boolean,
              "adapter"         :: Adapter,
              "revs_limit"      :: Int
            }
          | RemoteDBOptions {
              "ajax.cache"           :: Boolean,
              "ajax.headers"         :: List String,
              "auth.username"        :: String,
              "auth.password"        :: String,
              "ajax.withCredentials" :: Boolean
            }
          | IndexedDBOptions {
              "storage" :: StorageType
            }
          | WebSQLOptions {
              "size" :: Int
            }
          | OtherDBOptions a

data PouchDBDocument a = PouchDBDocument {
                          "_id"   :: Maybe String,
                          "_rev"  :: Maybe String
                          | a
                        }

data PouchDBInfo = PouchDBInfo {
  "db_name"    :: String,
  "doc_count"  :: Number,
  "update_seq" :: Number
}

-- | Logging helper
foreign import logRaw :: forall a e. a -> Eff (console :: CONSOLE | e) Unit

-- | PouchDB API
foreign import pouchDB      :: forall a e. Maybe String -> Maybe (PouchDBOptions a) -> Eff (err :: EXCEPTION | e) PouchDB
foreign import info         :: forall a e f. Maybe (a -> Eff e Unit) -> PouchDB -> Eff (err :: EXCEPTION | f) Unit
foreign import destroy      :: forall a b c e. Maybe (PouchDBOptions a) -> Maybe (b -> Eff c Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import put          :: forall a b c d e. PouchDBDocument a -> Maybe String -> Maybe String -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import post         :: forall a b c d e. PouchDBDocument a -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import get          :: forall a b c e. String -> Maybe (PouchDBOptions a) -> Maybe (b -> Eff c Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import remove       :: forall a b c d e. PouchDBDocument a -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import removeDocRev :: forall a b c d e. PouchDBDocument a -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import bulkDocs     :: forall a b c d e. Array (PouchDBDocument a) -> Maybe (PouchDBOptions b) -> Maybe (c -> Eff d Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit
foreign import allDocs      :: forall a b c e. Maybe (PouchDBOptions a) -> Maybe(b -> Eff c Unit) -> PouchDB -> Eff (err :: EXCEPTION | e) Unit


Implement `IsForeign` for `UsageLayoutArg`

module Neodoc.Data.UsageLayout where

import Prelude
import Data.Pretty (class Pretty, pretty)
import Data.Array as Array
import Data.Maybe (Maybe(..), maybe)
import Data.Foldable (intercalate)
import Data.List (List)
import Data.String (singleton) as String
import Data.Either (Either(..))
import Data.NonEmpty (NonEmpty, (:|))
import Data.Foreign as F
import Data.Foreign.Class as F
import Data.Foreign.Index as F
import Data.Foreign.Index ((!))
import Data.Foreign.Class
import Neodoc.Data.Layout
import Neodoc.Data.OptionArgument

-- This type can be specialized for elements of a usage section
type UsageLayout = Layout UsageLayoutArg
data UsageLayoutArg
  = Command     String Boolean
  | Positional  String Boolean
  | Option      String (Maybe OptionArgument) Boolean
  | OptionStack (NonEmpty Array Char) (Maybe OptionArgument) Boolean
  | EOA
  | Stdin
  | Reference String

instance isForeignUsageLayoutArg :: IsForeign UsageLayoutArg where
  read v = do
    typ :: String <- F.readProp "type" v

    case typ of
      "EOA" -> pure EOA
      "Stdin" -> pure Stdin
      "Command" ->
        Command
          <$> F.readProp "name"       v
          <*> F.readProp "repeatable" v
      "Positional" ->
        Positional
          <$> F.readProp "name"       v
          <*> F.readProp "repeatable" v
      "Reference" ->
        Reference
          <$> F.readProp "name" v
      "Option" ->
        Option
          <$> F.readProp "name" v
          <*> readOptionArgument v
          <*> F.readProp "repeatable" v
      "OptionStack" ->
        OptionStack
          <$> readOptionStack v
          <*> readOptionArgument v
          <*> F.readProp "repeatable" v
      _ -> Left $ F.errorAt "type" (F.JSONError $ "unknown type: " <> typ)

    where
    readOptionArgument v = do
      if F.hasOwnProperty "argument" v
        then do
          aV <- v ! "argument"
          Just <$> do
            OptionArgument
              <$> F.readProp "name" aV
              <*> F.readProp "repeatable" aV
        else pure Nothing

    readOptionStack v = do
      chars :: Array Char <- F.readProp "chars" v
      case Array.uncons chars of
        Just { head, tail } -> pure $ head :| tail
        _ -> Left $ F.errorAt "chars" (F.JSONError $ "missing chars")

instance eqUsageLayoutArg :: Eq UsageLayoutArg where
  eq (Command n r) (Command n' r') = n == n' && r == r'
  eq (Positional n r) (Positional n' r') = n == n' && r == r'
  eq (Option n a r) (Option n' a' r') = n == n' && a == a' && r == r'
  eq (OptionStack cs a r) (OptionStack cs' a' r') = cs == cs' && a == a' && r == r'
  eq EOA EOA = true
  eq Stdin Stdin = true
  eq (Reference s) (Reference s') = s == s'
  eq _ _ = false

instance showUsageLayoutArg :: Show UsageLayoutArg where
  show (Command n r) = "Command " <> show n <> " " <> show r
  show (Positional n r) = "Positional " <> show n <> " " <> show r
  show (Option n a r) = "Option " <> show n <> " " <> show a <> " " <> show r
  show (OptionStack cs a r) = "OptionStack " <> show cs <> " " <> show a <> " " <> show r
  show EOA = "EOA"
  show Stdin = "Stdin"
  show (Reference s) = "Reference " <> show s

instance prettyUsageLayoutArg :: Pretty UsageLayoutArg where
  pretty = go
    where
    go (Command    n r) = n <> rep r
    go (Positional n r) = n <> rep r
    go EOA = "--"
    go Stdin = "-"
    go (Reference n) = "[" <> n <> "]"
    go (Option n ma r)
      = "--"
      <> n
      <> maybe "" (("=" <> _) <<< pretty) ma
      <> rep r
    go (OptionStack cs ma r)
      = "-"
      <> intercalate "" (String.singleton <$> cs)
      <> maybe "" (("=" <> _) <<< pretty) ma
      <> rep r
    rep r = if r then "..." else ""

module Neodoc.Data.UsageLayout where

import Prelude
import Data.Pretty (class Pretty, pretty)
import Data.Maybe (Maybe, maybe)
import Data.Foldable (intercalate)
import Data.List (List)
import Data.String (singleton) as String
import Data.Either (Either(..))
import Data.NonEmpty (NonEmpty)
import Data.Foreign as F
import Data.Foreign.Class as F
import Data.Foreign.Index as F
import Data.Foreign.Class
import Neodoc.Data.Layout
import Neodoc.Data.OptionArgument

-- This type can be specialized for elements of a usage section
type UsageLayout = Layout UsageLayoutArg
data UsageLayoutArg
  = Command     String Boolean
  | Positional  String Boolean
  | Option      String (Maybe OptionArgument) Boolean
  | OptionStack (NonEmpty Array Char) (Maybe OptionArgument) Boolean
  | EOA
  | Stdin
  | Reference String

instance isForeignUsageLayoutArg :: IsForeign UsageLayoutArg where
  read v = do
    typ :: String <- F.readProp "type" v
    case typ of
      "Command" ->
        Command <$> F.readProp "name"       v
                <*> F.readProp "repeatable" v
      "Positional" ->
        Positional  <$> F.readProp "name"       v
                    <*> F.readProp "repeatable" v
      "EOA"   -> pure EOA
      "Stdin" -> pure Stdin
      "Reference" ->
        Reference <$> F.readProp "name" v
      "Option" ->
        Option <$> F.readProp "name"
               <*> readOptionArgument v
               <*> F.readProp

      -- "OptionStack" ->
      _ -> Left $ F.errorAt "type" (F.JSONError $ "unknown type: " <> typ)

instance eqUsageLayoutArg :: Eq UsageLayoutArg where
  eq (Command n r) (Command n' r') = n == n' && r == r'
  eq (Positional n r) (Positional n' r') = n == n' && r == r'
  eq (Option n a r) (Option n' a' r') = n == n' && a == a' && r == r'
  eq (OptionStack cs a r) (OptionStack cs' a' r') = cs == cs' && a == a' && r == r'
  eq EOA EOA = true
  eq Stdin Stdin = true
  eq (Reference s) (Reference s') = s == s'
  eq _ _ = false

instance showUsageLayoutArg :: Show UsageLayoutArg where
  show (Command n r) = "Command " <> show n <> " " <> show r
  show (Positional n r) = "Positional " <> show n <> " " <> show r
  show (Option n a r) = "Option " <> show n <> " " <> show a <> " " <> show r
  show (OptionStack cs a r) = "OptionStack " <> show cs <> " " <> show a <> " " <> show r
  show EOA = "EOA"
  show Stdin = "Stdin"
  show (Reference s) = "Reference " <> show s

instance prettyUsageLayoutArg :: Pretty UsageLayoutArg where
  pretty = go
    where
    go (Command    n r) = n <> rep r
    go (Positional n r) = n <> rep r
    go EOA = "--"
    go Stdin = "-"
    go (Reference n) = "[" <> n <> "]"
    go (Option n ma r)
      = "--"
      <> n
      <> maybe "" (("=" <> _) <<< pretty) ma
      <> rep r
    go (OptionStack cs ma r)
      = "-"
      <> intercalate "" (String.singleton <$> cs)
      <> maybe "" (("=" <> _) <<< pretty) ma
      <> rep r
    rep r = if r then "..." else ""


Export null and notNull.

Export null and notNull.

-- | This module defines types and functions for working with nullable types
-- | using the FFI.

module Data.Nullable
  ( Nullable
  , null
  , notNull
  , toMaybe
  , toNullable
  ) where

import Prelude

import Data.Eq (class Eq1)
import Data.Function (on)
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Maybe (Maybe(..), maybe)
import Data.Ord (class Ord1)

-- | A nullable type.
-- |
-- | This type constructor may be useful when interoperating with JavaScript functions
-- | which accept or return null values.
foreign import data Nullable :: Type -> Type

-- | The null value.
foreign import null :: forall a. Nullable a

foreign import nullable :: forall a r. Fn3 (Nullable a) r (a -> r) r

-- | Wrap a non-null value.
foreign import notNull :: forall a. a -> Nullable a

-- | Takes `Nothing` to `null`, and `Just a` to `a`.
toNullable :: forall a. Maybe a -> Nullable a
toNullable = maybe null notNull

-- | Represent `null` using `Maybe a` as `Nothing`.
toMaybe :: forall a. Nullable a -> Maybe a
toMaybe n = runFn3 nullable n Nothing Just

instance showNullable :: Show a => Show (Nullable a) where
  show = maybe "null" show <<< toMaybe

instance eqNullable :: Eq a => Eq (Nullable a) where
  eq = eq `on` toMaybe

instance eq1Nullable :: Eq1 Nullable where
  eq1 = eq

instance ordNullable :: Ord a => Ord (Nullable a) where
  compare = compare `on` toMaybe

instance ord1Nullable :: Ord1 Nullable where
  compare1 = compare

-- | This module defines types and functions for working with nullable types
-- | using the FFI.

module Data.Nullable
  ( Nullable
  , toMaybe
  , toNullable
  ) where

import Prelude

import Data.Eq (class Eq1)
import Data.Function (on)
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Maybe (Maybe(..), maybe)
import Data.Ord (class Ord1)

-- | A nullable type.
-- |
-- | This type constructor may be useful when interoperating with JavaScript functions
-- | which accept or return null values.
foreign import data Nullable :: Type -> Type

-- | The null value.
foreign import null :: forall a. Nullable a

foreign import nullable :: forall a r. Fn3 (Nullable a) r (a -> r) r

-- | Wrap a non-null value.
foreign import notNull :: forall a. a -> Nullable a

-- | Takes `Nothing` to `null`, and `Just a` to `a`.
toNullable :: forall a. Maybe a -> Nullable a
toNullable = maybe null notNull

-- | Represent `null` using `Maybe a` as `Nothing`.
toMaybe :: forall a. Nullable a -> Maybe a
toMaybe n = runFn3 nullable n Nothing Just

instance showNullable :: Show a => Show (Nullable a) where
  show = maybe "null" show <<< toMaybe

instance eqNullable :: Eq a => Eq (Nullable a) where
  eq = eq `on` toMaybe

instance eq1Nullable :: Eq1 Nullable where
  eq1 = eq

instance ordNullable :: Ord a => Ord (Nullable a) where
  compare = compare `on` toMaybe

instance ord1Nullable :: Ord1 Nullable where
  compare1 = compare


Improve placeholder example, fix #41

Improve placeholder example, fix #41

module Example.Placeholder where

import Data.Void
import Data.Maybe
import Data.Tuple

import Control.Monad.Eff

import DOM

import Halogen
import Halogen.Signal
import Halogen.Internal.VirtualDOM (VTree(), widget)

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A

import qualified Halogen.Themes.Bootstrap3 as B

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

-- | An example of a function which creates a DOM node to
-- | be embedded inside a HTML document.
foreign import createParagraph
  "function createParagraph(s) {\
  \  return function() {\
  \    var p = document.createElement('p');\
  \    p.style.color = 'red';\
  \    p.appendChild(document.createTextNode(s));\
  \    return p;\
  \  };\
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) Node

-- | Instead of embedding nodes directly, we create a placeholder type,
-- | and insert placeholders into our document.
-- |
-- | This way, we keep our view pure, and can separate out impure code into the
-- | renderer function, below.
data Placeholder = Placeholder String

view :: forall r. H.HTML Placeholder r
view = H.div (A.class_ B.container)
          [ H.h1_ [ H.text "placeholder" ]
          , H.placeholder (Placeholder "A custom widget will be rendered here.")
          ]

-- | Our placeholder will be replaced with a widget, which we will create using the `widget`
-- | function from `Halogen.Internal.VirtualDOM`.
makeWidget :: String -> VTree
makeWidget s = widget init update destroy
  where
  init :: forall eff. Eff (dom :: DOM | eff) Node
  init = createParagraph s

  update :: forall eff. Node -> Eff (dom :: DOM | eff) (Maybe Node)
  update _ = pure Nothing

  destroy :: forall eff. Node -> Eff (dom :: DOM | eff) Unit
  destroy _ = return unit

-- | Convert placeholders into `VTrees`.
-- |
-- | In a real application, this function might render a third party component using `widget`.
renderer :: Placeholder -> VTree
renderer (Placeholder s) = makeWidget s

ui :: forall i eff. UI i Placeholder Void eff
ui = { view: pure view, handler: absurd, renderer: renderer }

main = do
  Tuple node _ <- runUI ui
  appendToBody node

module Example.Placeholder where

import Data.Void
import Data.Tuple

import Control.Monad.Eff

import DOM

import Halogen
import Halogen.Signal
import Halogen.Internal.VirtualDOM (VTree(), vtext)

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A

import qualified Halogen.Themes.Bootstrap3 as B

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

data Placeholder = Placeholder String

view :: forall r. H.HTML Placeholder r
view = H.div (A.class_ B.container)
          [ H.h1_ [ H.text "placeholder" ]
          , H.placeholder (Placeholder "This text rendered by renderPlaceholder.")
          ]

-- | Convert placeholders into `VTrees`.
-- |
-- | In a real application, this function might render a third party component using `widget`.
renderer :: Placeholder -> VTree
renderer (Placeholder s) = vtext s

ui :: forall i eff. UI i Placeholder Void eff
ui = { view: pure view, handler: absurd, renderer: renderer }

main = do
  Tuple node _ <- runUI ui
  appendToBody node


Run a garbage collection in Machine.new to drop unused globals

module Lambda.Machine
  ( Machine(..)
  , new
  , step
  , add
  , remove
  , halted
  , snapshot
  ) where

import Lambda.Prelude hiding (add)

import Lambda.Language.Expr (Expr(..))
import Lambda.Language.Name (Name)
import Lambda.Language.PrettyPrint (prettyPrint, sugar)
import Lambda.Language.Syntax (Syntax(..))
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 Lambda.Machine.Node (Node(..), Stuck(..))
import Lambda.Machine.Node as Node
import Lambda.Machine.Stack (Stack)
import Lambda.Machine.Stack as Stack
import Lambda.Machine.Stash (Stash)
import Lambda.Machine.Stash as Stash
import Lambda.Machine.Trace (Trace(..))
import Lambda.Machine.Trace as Trace
import Partial.Unsafe (unsafeCrashWith)

-- | Machine-state based roughly on the Template Instantiation Machine
-- | from Simon Peyton-Jones & David Lester's _Implementing Functional
-- | Languages: A Tutorial_.
-- |
-- | The Template Instantiation Machine is a very simple graph
-- | reduction interpreter. It's too slow and inflexible for a "real"
-- | implementation, but for Lambda Machine, all we care about is that
-- | we can either retain or reconstruct enough syntactic information
-- | to incrementally do lazy-evaluation in human-comprehensible steps.
-- | The Template Instantiation Machine works for our use-case.
-- |
-- | Note that this implementation differs from the Template
-- | Instantiation Machine as specified in the literature:
-- | 1. We do not lambda-lift the program to supercombinators. Instead
-- |    we construct closures for lambdas encountered at runtime.
-- | 2. We evaluate applications one argument at a time, like a person
-- |    might do using pen and paper.
-- | 3. We evaluate inside of under-applied lambdas by secretly
-- |    applying them to special `Stuck` values that cannot themselves
-- |    be further evaluated. This makes certain functions (e.g. the
-- |    predecessor function on Church numerals) work that would
-- |    otherwise get stuck too early in a "real" language.
-- | 4. We retain a pointer to the root expression even as we abandon
-- |    the parts of it that we cannot reduce. This is the `root`
-- |    field. Since the machine updates nodes when they're evaluated,
-- |    we can dereference the `root` to track evaluation.
-- | 5. We call the "dump" the "stash". I don't remember why; maybe it
-- |    looks nice next to stack? This detail isn't important, it just
-- |    helps if you're comparing directly.
-- |
type Machine =
  { root :: Address
  , stack :: Stack
  , stash :: Stash
  , heap :: Heap Node
  , globals :: Globals
  , trace :: Trace
  }

-- | Create a new `Machine` given a list of top-level definitions and
-- | a root expression to start evaluating. Run a garbage collection
-- | up front to drop globals we won't need.
new :: forall f. Foldable f => f (Tuple Name Expr) -> Expr -> Machine
new rawGlobals expr =
  { root
  , heap
  , globals
  , stack: Stack.singleton root
  , stash: Stash.empty
  , trace: Start
  }
 where
  empty = { heap: Heap.empty, globals: Globals.empty }
  {root, globals, heap} = flip evalState empty $ do
    traverse_ (uncurry Node.define) rawGlobals
    root <- Node.compile expr
    Heap.gc [root] Node.children
    heap <- gets _.heap
    globals <- gets _.globals
    pure {root, globals, heap}

-- | Has the `Machine` halted?
halted :: Machine -> Boolean
halted m = case m.trace of
  Halted _ -> true
  _ -> false

-- | Add a new top-level definition to an already running `Machine`
add :: Name -> Expr -> Machine -> Machine
add name expr = execState $ Node.define name expr

-- | Remove a top-level definition from an already running `Machine`
remove :: Name -> Machine -> Machine
remove name = execState $ Globals.remove name

-- | Update the `trace` field with a summary of the most recent step.
emit :: forall s m. MonadState { trace :: Trace | s } m => Trace -> m Unit
emit message = modify_ _ { trace = message }

-- | Perform one (big) step of evaluation. We consider the following to
-- | be big steps:
-- | 1. Replacing a global name with its definition
-- | 2. Beta-reduction
-- | 3. Halting
-- |
-- | See the `interesting` function for where this is exactly spelled
-- | out.
step :: Machine -> Machine
step = stepWith interesting

-- | Perform steps in constant stack space until the `Trace`
-- | satisfies the first argument. Passing `const true` would
-- | correspond to truly small-step evaluation. Specifically, you
-- | would observe stack unwinding, pointer-chasing, etc.
stepWith :: (Trace -> Boolean) -> Machine -> Machine
stepWith stop = execState do
  tailRecM go unit
  roots <- getRoots
  Heap.gc roots Node.children
 where
  go _ = do
    { top } <- gets _.stack
    eval top =<< Heap.fetch top
    trace <- gets _.trace
    pure $ next trace unit

  next trace
    | stop trace = Done
    | otherwise = Loop

-- | Find all root addresses for garbage collecting. Note that
-- | top-level definitions are not considered roots.
getRoots :: forall m . MonadState Machine m => m (Array Address)
getRoots = do
  {root, stack, stash, globals, trace} <- get
  pure $ fold
    [ [root]
    , Stack.roots stack
    , Stash.roots stash
    , Trace.roots trace
    ]

-- | Was the last step interesting?
interesting :: Trace -> Boolean
interesting = case _ of
  Fetched _ -> true
  Substituted _ _ -> true
  Halted _ -> true
  _ -> false

-- | Perform one state transition based on the `Node` at the top
-- | of the stack.
eval :: forall m. MonadState Machine m => Address -> Node -> m Unit
eval top = case _ of
  -- Application node - unwind by pushing the left-hand-side onto the
  -- stack
  Node f _ -> do
    Stack.push f
    emit $ Unwound f

  -- Pointer node - dereference and push onto the stack. If the pointee
  -- is being applied, update the application node to point at it.
  Pointer address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> pure unit
    Stack.replace address
    emit $ Followed address

  -- Top-level definition - push the address onto the stack. If the
  -- address is being applied, update the application node to point at
  -- it.
  Global name address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> Heap.update top $ Pointer address
    Stack.replace address
    emit $ Fetched name

  -- Closure - if there is an argument, push it on the front of the
  -- closure's environment and instantiate the body. Then update the
  -- application node to point at the newly constructed node.
  --
  -- Otherwise, allocate a stuck value and instantiate the body with
  -- that in the environment instead. Finally allocate a stuck lambda
  -- and update the top of the stack to point at it.
  Closure _ env name e ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Node.instantiateAt app (Cons arg env) e
        Stack.discard
        emit $ Substituted name arg
      Nothing -> do
        arg <- Heap.alloc $ Stuck $ StuckVar name
        node <- Node.instantiate (Cons arg env) e
        Heap.update top $ Stuck $ StuckBind name node
        Stack.replace node
        emit $ WentUnder top

  -- Stuck node - if there is an argument, push everything beneath it
  -- onto the stash, and continue evaluation on the argument.
  --
  -- Otherwise, attempt to restore the stash and keep going. If there's
  -- nothing left, we're done.
  Stuck _ ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Stuck $ StuckApp top arg
        Stack.discard
        Stack.replace arg
        Stash.suspend
        emit $ Discarded top arg
      Nothing ->
        Stash.restore >>= case _ of
          Just arg -> emit $ Discarded top arg
          Nothing -> emit $ Halted top

-- | Fetch the right-hand-side of an application node or crash
fetchArg :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Address
fetchArg address = do
  node <- Heap.fetch address
  case node of
    Node _ arg -> pure arg
    _ -> unsafeCrashWith $ fold
      [ "Non-application below top of stack: "
      , show node
      ]

-- | Fetch the node and convert it to `Syntax`.
formatNode :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Syntax
formatNode address = do
  node <- Heap.fetch address
  case node of
    Node f a -> Apply <$> formatNode f <*> formatNode a
    Closure _ env0 name e -> do
      env <- traverse formatNode env0
      pure $ Lambda name $ toSyntax (Var name : env) e
    Stuck term -> formatStuck term
    Pointer a -> formatNode a
    Global name _ -> pure $ Var name

-- | Convert an `Expr` in a `Closure` to `Syntax`.
toSyntax :: List Syntax -> Expr -> Syntax
toSyntax env = case _ of
  Bind n _ e -> Lambda n $ toSyntax (Var n : env) e
  App f a -> Apply (toSyntax env f) (toSyntax env a)
  Bound i -> Node.deref i env
  Free n -> Var n

-- | Format a `Stuck` node.
formatStuck :: forall s m. MonadState { heap :: Heap Node | s } m => Stuck -> m Syntax
formatStuck = case _ of
  StuckVar name -> pure $ Var name
  StuckBind name e  -> Lambda name <$> formatNode e
  StuckApp f a -> Apply <$> formatNode f <*> formatNode a

-- | Pretty-print `Syntax`
formatSyntax :: Syntax -> String
formatSyntax = sugar <<< prettyPrint

-- | Convert a `Trace` to a human-readable explanation.
formatTrace :: forall s m. MonadState { heap :: Heap Node | s } m => Trace -> m String
formatTrace = map fold <<< case _ of
  Start -> pure ["Start"]
  Unwound address -> do
    node <- formatNode address
    pure
      [ "Unwound "
      , formatSyntax node
      ]
  Followed address -> do
    node <- formatNode address
    pure
      [ "Followed #"
      , show address
      , " to "
      , formatSyntax node
      ]
  Fetched name -> pure
    [ "Fetched "
    , show name
    ]
  Instantiated address -> do
    node <- formatNode address
    pure
      [ "Instantiated new copy of "
      , formatSyntax node
      ]
  Substituted name address -> do
    stuck <- isStuck <$> Heap.fetch address
    node <- formatNode address
    pure
      [ "Substituted "
      , if stuck then "stuck term " else ""
      , formatSyntax node
      , " in for "
      , show name
      ]
  WentUnder address -> do
    node <- formatNode address
    pure
      [ "Went under stuck lambda "
      , formatSyntax node
      ]
  Discarded discarded next -> do
    stuck <- formatNode discarded
    node <- formatNode next
    pure
      [ "Discarded stuck term "
      , formatSyntax stuck
      , "; evaluating "
      , formatSyntax node
      ]
  Halted address -> do
    node <- formatNode address
    pure
      [ "Halted with "
      , formatSyntax node
      , " on top of stack"
      ]
 where
  isStuck = case _ of
    Stuck _ -> true
    _ -> false

-- | Take a snapshot of a `Machine` by formatting the `root` node and
-- | producing a human-readable trace.
snapshot :: Machine -> { root :: Syntax, trace :: String }
snapshot = evalState do
  root <- formatNode =<< gets _.root
  trace <- formatTrace =<< gets _.trace
  pure { root, trace }

module Lambda.Machine
  ( Machine(..)
  , new
  , step
  , add
  , remove
  , halted
  , snapshot
  ) where

import Lambda.Prelude hiding (add)

import Lambda.Language.Expr (Expr(..))
import Lambda.Language.Name (Name)
import Lambda.Language.PrettyPrint (prettyPrint, sugar)
import Lambda.Language.Syntax (Syntax(..))
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 Lambda.Machine.Node (Node(..), Stuck(..))
import Lambda.Machine.Node as Node
import Lambda.Machine.Stack (Stack)
import Lambda.Machine.Stack as Stack
import Lambda.Machine.Stash (Stash)
import Lambda.Machine.Stash as Stash
import Lambda.Machine.Trace (Trace(..))
import Lambda.Machine.Trace as Trace
import Partial.Unsafe (unsafeCrashWith)

-- | Machine-state based roughly on the Template Instantiation Machine
-- | from Simon Peyton-Jones & David Lester's _Implementing Functional
-- | Languages: A Tutorial_.
-- |
-- | The Template Instantiation Machine is a very simple graph
-- | reduction interpreter. It's too slow and inflexible for a "real"
-- | implementation, but for Lambda Machine, all we care about is that
-- | we can either retain or reconstruct enough syntactic information
-- | to incrementally do lazy-evaluation in human-comprehensible steps.
-- | The Template Instantiation Machine works for our use-case.
-- |
-- | Note that this implementation differs from the Template
-- | Instantiation Machine as specified in the literature:
-- | 1. We do not lambda-lift the program to supercombinators. Instead
-- |    we construct closures for lambdas encountered at runtime.
-- | 2. We evaluate applications one argument at a time, like a person
-- |    might do using pen and paper.
-- | 3. We evaluate inside of under-applied lambdas by secretly
-- |    applying them to special `Stuck` values that cannot themselves
-- |    be further evaluated. This makes certain functions (e.g. the
-- |    predecessor function on Church numerals) work that would
-- |    otherwise get stuck too early in a "real" language.
-- | 4. We retain a pointer to the root expression even as we abandon
-- |    the parts of it that we cannot reduce. This is the `root`
-- |    field. Since the machine updates nodes when they're evaluated,
-- |    we can dereference the `root` to track evaluation.
-- | 5. We call the "dump" the "stash". I don't remember why; maybe it
-- |    looks nice next to stack? This detail isn't important, it just
-- |    helps if you're comparing directly.
-- |
type Machine =
  { root :: Address
  , stack :: Stack
  , stash :: Stash
  , heap :: Heap Node
  , globals :: Globals
  , trace :: Trace
  }

-- | Create a new `Machine` given a list of top-level definitions and
-- | a root expression to start evaluating.
new :: forall f. Foldable f => f (Tuple Name Expr) -> Expr -> Machine
new rawGlobals expr =
  { root
  , heap
  , globals
  , stack: Stack.singleton root
  , stash: Stash.empty
  , trace: Start
  }
 where
  empty = { heap: Heap.empty, globals: Globals.empty }
  {root, globals, heap} = flip evalState empty $ do
    traverse_ (uncurry Node.define) rawGlobals
    root <- Node.compile expr
    heap <- gets _.heap
    globals <- gets _.globals
    pure {root, globals, heap}

-- | Has the `Machine` halted?
halted :: Machine -> Boolean
halted m = case m.trace of
  Halted _ -> true
  _ -> false

-- | Add a new top-level definition to an already running `Machine`
add :: Name -> Expr -> Machine -> Machine
add name expr = execState $ Node.define name expr

-- | Remove a top-level definition from an already running `Machine`
remove :: Name -> Machine -> Machine
remove name = execState $ Globals.remove name

-- | Update the `trace` field with a summary of the most recent step.
emit :: forall s m. MonadState { trace :: Trace | s } m => Trace -> m Unit
emit message = modify_ _ { trace = message }

-- | Perform one (big) step of evaluation. We consider the following to
-- | be big steps:
-- | 1. Replacing a global name with its definition
-- | 2. Beta-reduction
-- | 3. Halting
-- |
-- | See the `interesting` function for where this is exactly spelled
-- | out.
step :: Machine -> Machine
step = stepWith interesting

-- | Perform steps in constant stack space until the `Trace`
-- | satisfies the first argument. Passing `const true` would
-- | correspond to truly small-step evaluation. Specifically, you
-- | would observe stack unwinding, pointer-chasing, etc.
stepWith :: (Trace -> Boolean) -> Machine -> Machine
stepWith stop = execState do
  tailRecM go unit
  roots <- getRoots
  Heap.gc roots Node.children
 where
  go _ = do
    { top } <- gets _.stack
    eval top =<< Heap.fetch top
    trace <- gets _.trace
    pure $ next trace unit

  next trace
    | stop trace = Done
    | otherwise = Loop

-- | Find all root addresses for garbage collecting. Note that
-- | top-level definitions are not considered roots.
getRoots :: forall m . MonadState Machine m => m (Array Address)
getRoots = do
  {root, stack, stash, globals, trace} <- get
  pure $ fold
    [ [root]
    , Stack.roots stack
    , Stash.roots stash
    , Trace.roots trace
    ]

-- | Was the last step interesting?
interesting :: Trace -> Boolean
interesting = case _ of
  Fetched _ -> true
  Substituted _ _ -> true
  Halted _ -> true
  _ -> false

-- | Perform one state transition based on the `Node` at the top
-- | of the stack.
eval :: forall m. MonadState Machine m => Address -> Node -> m Unit
eval top = case _ of
  -- Application node - unwind by pushing the left-hand-side onto the
  -- stack
  Node f _ -> do
    Stack.push f
    emit $ Unwound f

  -- Pointer node - dereference and push onto the stack. If the pointee
  -- is being applied, update the application node to point at it.
  Pointer address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> pure unit
    Stack.replace address
    emit $ Followed address

  -- Top-level definition - push the address onto the stack. If the
  -- address is being applied, update the application node to point at
  -- it.
  Global name address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> Heap.update top $ Pointer address
    Stack.replace address
    emit $ Fetched name

  -- Closure - if there is an argument, push it on the front of the
  -- closure's environment and instantiate the body. Then update the
  -- application node to point at the newly constructed node.
  --
  -- Otherwise, allocate a stuck value and instantiate the body with
  -- that in the environment instead. Finally allocate a stuck lambda
  -- and update the top of the stack to point at it.
  Closure _ env name e ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Node.instantiateAt app (Cons arg env) e
        Stack.discard
        emit $ Substituted name arg
      Nothing -> do
        arg <- Heap.alloc $ Stuck $ StuckVar name
        node <- Node.instantiate (Cons arg env) e
        Heap.update top $ Stuck $ StuckBind name node
        Stack.replace node
        emit $ WentUnder top

  -- Stuck node - if there is an argument, push everything beneath it
  -- onto the stash, and continue evaluation on the argument.
  --
  -- Otherwise, attempt to restore the stash and keep going. If there's
  -- nothing left, we're done.
  Stuck _ ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Stuck $ StuckApp top arg
        Stack.discard
        Stack.replace arg
        Stash.suspend
        emit $ Discarded top arg
      Nothing ->
        Stash.restore >>= case _ of
          Just arg -> emit $ Discarded top arg
          Nothing -> emit $ Halted top

-- | Fetch the right-hand-side of an application node or crash
fetchArg :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Address
fetchArg address = do
  node <- Heap.fetch address
  case node of
    Node _ arg -> pure arg
    _ -> unsafeCrashWith $ fold
      [ "Non-application below top of stack: "
      , show node
      ]

-- | Fetch the node and convert it to `Syntax`.
formatNode :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Syntax
formatNode address = do
  node <- Heap.fetch address
  case node of
    Node f a -> Apply <$> formatNode f <*> formatNode a
    Closure _ env0 name e -> do
      env <- traverse formatNode env0
      pure $ Lambda name $ toSyntax (Var name : env) e
    Stuck term -> formatStuck term
    Pointer a -> formatNode a
    Global name _ -> pure $ Var name

-- | Convert an `Expr` in a `Closure` to `Syntax`.
toSyntax :: List Syntax -> Expr -> Syntax
toSyntax env = case _ of
  Bind n _ e -> Lambda n $ toSyntax (Var n : env) e
  App f a -> Apply (toSyntax env f) (toSyntax env a)
  Bound i -> Node.deref i env
  Free n -> Var n

-- | Format a `Stuck` node.
formatStuck :: forall s m. MonadState { heap :: Heap Node | s } m => Stuck -> m Syntax
formatStuck = case _ of
  StuckVar name -> pure $ Var name
  StuckBind name e  -> Lambda name <$> formatNode e
  StuckApp f a -> Apply <$> formatNode f <*> formatNode a

-- | Pretty-print `Syntax`
formatSyntax :: Syntax -> String
formatSyntax = sugar <<< prettyPrint

-- | Convert a `Trace` to a human-readable explanation.
formatTrace :: forall s m. MonadState { heap :: Heap Node | s } m => Trace -> m String
formatTrace = map fold <<< case _ of
  Start -> pure ["Start"]
  Unwound address -> do
    node <- formatNode address
    pure
      [ "Unwound "
      , formatSyntax node
      ]
  Followed address -> do
    node <- formatNode address
    pure
      [ "Followed #"
      , show address
      , " to "
      , formatSyntax node
      ]
  Fetched name -> pure
    [ "Fetched "
    , show name
    ]
  Instantiated address -> do
    node <- formatNode address
    pure
      [ "Instantiated new copy of "
      , formatSyntax node
      ]
  Substituted name address -> do
    stuck <- isStuck <$> Heap.fetch address
    node <- formatNode address
    pure
      [ "Substituted "
      , if stuck then "stuck term " else ""
      , formatSyntax node
      , " in for "
      , show name
      ]
  WentUnder address -> do
    node <- formatNode address
    pure
      [ "Went under stuck lambda "
      , formatSyntax node
      ]
  Discarded discarded next -> do
    stuck <- formatNode discarded
    node <- formatNode next
    pure
      [ "Discarded stuck term "
      , formatSyntax stuck
      , "; evaluating "
      , formatSyntax node
      ]
  Halted address -> do
    node <- formatNode address
    pure
      [ "Halted with "
      , formatSyntax node
      , " on top of stack"
      ]
 where
  isStuck = case _ of
    Stuck _ -> true
    _ -> false

-- | Take a snapshot of a `Machine` by formatting the `root` node and
-- | producing a human-readable trace.
snapshot :: Machine -> { root :: Syntax, trace :: String }
snapshot = evalState do
  root <- formatNode =<< gets _.root
  trace <- formatTrace =<< gets _.trace
  pure { root, trace }


Do not include 'where' in the externs file for an empty class

module Language.PureScript.CodeGen.Externs (moduleToPs) where

import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Data.Array (filter, map, mapMaybe, null)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foldable (elem, find, for_, traverse_)
import Data.Monoid
import Data.String (joinWith)
import Data.Tuple
import Data.Tuple3

import qualified Data.Map as M

import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.Errors (theImpossibleHappened)
import Language.PureScript.Names
import Language.PureScript.Pretty.Kinds
import Language.PureScript.Pretty.Types
import Language.PureScript.TypeClassDictionaries

-- |
-- Generate foreign imports for all declarations in a module
--
moduleToPs :: Module -> Environment -> String
moduleToPs (Module _ _ Nothing) _ = theImpossibleHappened "Module exports were not elaborated in moduleToPs"
moduleToPs (Module moduleName ds (Just exts)) (Environment env) = joinWith "\n" <<< execWriter $ do
  tell [ "module " ++ runModuleName moduleName ++ " where"]
  traverse_ declToPs ds
  traverse_ exportToPs exts
  where

    declToPs :: Declaration -> Writer [String] {}
    declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
    declToPs (FixityDeclaration (Fixity assoc prec) ident) =
      tell [ joinWith " " [ show assoc, show prec, ident ] ]
    declToPs (PositionedDeclaration _ d) = declToPs d
    declToPs _ = return {}

    exportToPs :: DeclarationRef -> Writer [String] {}
    exportToPs (PositionedDeclarationRef _ r) = exportToPs r
    exportToPs (TypeRef pn dctors) =
      case Qualified (Just moduleName) pn `M.lookup` env.types of
        Nothing -> theImpossibleHappened $ show pn ++ " has no kind in exportToPs"
        Just (Tuple kind ExternData) ->
          tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
        Just (Tuple _ (DataType args tys)) -> do
          let dctors' = fromMaybe (map fst tys) dctors
              printDctor dctor = case dctor `lookup` tys of
                                   Nothing -> Nothing
                                   Just tyArgs -> Just $ show dctor ++ " " ++ joinWith " " (map prettyPrintTypeAtom tyArgs)
          tell ["data " ++ show pn ++ " " ++ joinWith " " args ++ (if null dctors' then "" else " = " ++ joinWith " | " (mapMaybe printDctor dctors'))]
        Just (Tuple _ TypeSynonym) ->
          case Qualified (Just moduleName) pn `M.lookup` env.typeSynonyms of
            Nothing -> theImpossibleHappened $ show pn ++ " has no type synonym info in exportToPs"
            Just (Tuple args synTy) ->
              tell ["type " ++ show pn ++ " " ++ joinWith " " args ++ " = " ++ prettyPrintType synTy]
        _ -> theImpossibleHappened "Invalid input in exportToPs"

    exportToPs (ValueRef ident) =
      case (Tuple moduleName ident) `M.lookup` env.names of
        Nothing -> theImpossibleHappened $ show ident ++ " has no type in exportToPs"
        Just (Tuple ty nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
          tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
        _ -> return {}
    exportToPs (TypeClassRef className) =
      case Qualified (Just moduleName) className `M.lookup` env.typeClasses of
        Nothing -> theImpossibleHappened $ show className ++ " has no type class definition in exportToPs"
        Just (Tuple3 args members implies) -> do
          let impliesString = if null implies then "" else "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
          let exportedMembers = filter (isValueExported <<< fst) members
          tell ["class " ++ impliesString ++ show className ++ " " ++ joinWith " " args ++ (if null exportedMembers then "" else " where")]
          for_ exportedMembers $ \(Tuple member ty) ->
            tell [ "  " ++ show member ++ " :: " ++ prettyPrintType ty ]

    exportToPs (TypeInstanceRef ident) = do
      case find (((==) (Qualified (Just moduleName) ident)) <<< (\(TypeClassDictionaryInScope tcd) -> tcd.name)) $ M.values env.typeClassDictionaries of
        Nothing -> theImpossibleHappened "Type class instance has no dictionary in exportToPs"
        Just (TypeClassDictionaryInScope tcd) -> do
          let constraintsText = case fromMaybe [] tcd.dependencies of
                                  [] -> ""
                                  cs -> "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) cs) ++ ") => "
          tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show tcd.className ++ " " ++ joinWith " " (map prettyPrintTypeAtom tcd.instanceTypes)]

    isValueExported :: Ident -> Boolean
    isValueExported ident = ValueRef ident `elem` exts

    -- TODO: put this somewhere else
    lookup :: forall a b. (Eq a) => a -> [Tuple a b] -> Maybe b
    lookup key ((Tuple x y) : xys) = if key == x then Just y else lookup key xys
    lookup _ [] = Nothing

module Language.PureScript.CodeGen.Externs (moduleToPs) where

import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Data.Array (filter, map, mapMaybe, null)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foldable (elem, find, for_, traverse_)
import Data.Monoid
import Data.String (joinWith)
import Data.Tuple
import Data.Tuple3

import qualified Data.Map as M

import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.Errors (theImpossibleHappened)
import Language.PureScript.Names
import Language.PureScript.Pretty.Kinds
import Language.PureScript.Pretty.Types
import Language.PureScript.TypeClassDictionaries

-- |
-- Generate foreign imports for all declarations in a module
--
moduleToPs :: Module -> Environment -> String
moduleToPs (Module _ _ Nothing) _ = theImpossibleHappened "Module exports were not elaborated in moduleToPs"
moduleToPs (Module moduleName ds (Just exts)) (Environment env) = joinWith "\n" <<< execWriter $ do
  tell [ "module " ++ runModuleName moduleName ++ " where"]
  traverse_ declToPs ds
  traverse_ exportToPs exts
  where

    declToPs :: Declaration -> Writer [String] {}
    declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
    declToPs (FixityDeclaration (Fixity assoc prec) ident) =
      tell [ joinWith " " [ show assoc, show prec, ident ] ]
    declToPs (PositionedDeclaration _ d) = declToPs d
    declToPs _ = return {}

    exportToPs :: DeclarationRef -> Writer [String] {}
    exportToPs (PositionedDeclarationRef _ r) = exportToPs r
    exportToPs (TypeRef pn dctors) =
      case Qualified (Just moduleName) pn `M.lookup` env.types of
        Nothing -> theImpossibleHappened $ show pn ++ " has no kind in exportToPs"
        Just (Tuple kind ExternData) ->
          tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
        Just (Tuple _ (DataType args tys)) -> do
          let dctors' = fromMaybe (map fst tys) dctors
              printDctor dctor = case dctor `lookup` tys of
                                   Nothing -> Nothing
                                   Just tyArgs -> Just $ show dctor ++ " " ++ joinWith " " (map prettyPrintTypeAtom tyArgs)
          tell ["data " ++ show pn ++ " " ++ joinWith " " args ++ (if null dctors' then "" else " = " ++ joinWith " | " (mapMaybe printDctor dctors'))]
        Just (Tuple _ TypeSynonym) ->
          case Qualified (Just moduleName) pn `M.lookup` env.typeSynonyms of
            Nothing -> theImpossibleHappened $ show pn ++ " has no type synonym info in exportToPs"
            Just (Tuple args synTy) ->
              tell ["type " ++ show pn ++ " " ++ joinWith " " args ++ " = " ++ prettyPrintType synTy]
        _ -> theImpossibleHappened "Invalid input in exportToPs"

    exportToPs (ValueRef ident) =
      case (Tuple moduleName ident) `M.lookup` env.names of
        Nothing -> theImpossibleHappened $ show ident ++ " has no type in exportToPs"
        Just (Tuple ty nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
          tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
        _ -> return {}
    exportToPs (TypeClassRef className) =
      case Qualified (Just moduleName) className `M.lookup` env.typeClasses of
        Nothing -> theImpossibleHappened $ show className ++ " has no type class definition in exportToPs"
        Just (Tuple3 args members implies) -> do
          let impliesString = if null implies then "" else "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
          tell ["class " ++ impliesString ++ show className ++ " " ++ joinWith " " args ++ " where"]
          for_ (filter (isValueExported <<< fst) members) $ \(Tuple member ty) ->
            tell [ "  " ++ show member ++ " :: " ++ prettyPrintType ty ]

    exportToPs (TypeInstanceRef ident) = do
      case find (((==) (Qualified (Just moduleName) ident)) <<< (\(TypeClassDictionaryInScope tcd) -> tcd.name)) $ M.values env.typeClassDictionaries of
        Nothing -> theImpossibleHappened "Type class instance has no dictionary in exportToPs"
        Just (TypeClassDictionaryInScope tcd) -> do
          let constraintsText = case fromMaybe [] tcd.dependencies of
                                  [] -> ""
                                  cs -> "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) cs) ++ ") => "
          tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show tcd.className ++ " " ++ joinWith " " (map prettyPrintTypeAtom tcd.instanceTypes)]

    isValueExported :: Ident -> Boolean
    isValueExported ident = ValueRef ident `elem` exts

    -- TODO: put this somewhere else
    lookup :: forall a b. (Eq a) => a -> [Tuple a b] -> Maybe b
    lookup key ((Tuple x y) : xys) = if key == x then Just y else lookup key xys
    lookup _ [] = Nothing


C# style

C# style

Original commit 1c8ef0422a62d8ffc0afa84ea26e7c37ac0a37ed

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

import Utils (removeElement)

type CSDoc = Doc Unit

forbiddenNames :: Array String
forbiddenNames = [ "Converter", "JsonConverter", "Type" ]

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , render: renderGraphToCSharp
    }

renderGraphToCSharp :: IRGraph -> String
renderGraphToCSharp graph =
    runDoc csharpDoc nameForClass unionName unionPredicate nextNameToTry (S.fromFoldable forbiddenNames) graph unit
    where
        unionPredicate =
            case _ of
            IRUnion ur ->
                let s = unionToSet ur
                in
                    if isNothing $ nullableFromSet s then
                        Just s
                    else
                        Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) =
            csNameStyle $ combineNames names
        nextNameToTry s =
            "Other" <> s

unionName :: List String -> String
unionName s =
    s
    # L.sort
    <#> csNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToCSharp :: Set IRType -> CSDoc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

renderTypeToCSharp :: IRType -> CSDoc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object"
    IRNull -> pure "object"
    IRInteger -> pure "int"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp $ unionToSet types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

csharpDoc :: CSDoc Unit
csharpDoc = do
    line """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
//
//    var data = QuickType.Converter.FromJson(jsonString);
//
namespace QuickType
{"""

    blank
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    line "}"

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderJsonConverter :: CSDoc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions ": JsonConverter"
    line "{"
    indent do
        IRGraph { toplevel } <- getGraph
        toplevelType <- renderTypeToCSharp toplevel
        line "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        line
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        when haveUnions do
            blank
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"
            blank
            line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
            line "{"
            indent $ line "throw new NotImplementedException();"
            line "}"
            blank
            line "public override bool CanWrite => false;"
    line "}"

tokenCase :: String -> CSDoc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> CSDoc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            line "break;"

unionFieldName :: IRType -> CSDoc String
unionFieldName t = do
    graph <- getGraph
    let typeName = typeNameForUnion graph t
    pure $ csNameStyle typeName

deserialize :: String -> String -> CSDoc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> CSDoc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> Set IRType -> CSDoc Unit
renderPrimitiveDeserializer tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> CSDoc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRType -> Boolean) -> String -> Set IRType -> CSDoc Unit
renderGenericDeserializer predicate tokenType types = unsafePartial $
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: Set IRType -> CSDoc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ "public struct " <> name
    line "{"
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToCSharp $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool allTypes
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"
    line "}"

renderCSharpClass :: IRClassData -> String -> CSDoc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "public class " <> className
    line "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            let csPropName = lookupName pname propertyNames
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            blank
    line "}"

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

import Utils (removeElement)

type CSDoc = Doc Unit

forbiddenNames :: Array String
forbiddenNames = [ "Converter", "JsonConverter", "Type" ]

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , render: renderGraphToCSharp
    }

renderGraphToCSharp :: IRGraph -> String
renderGraphToCSharp graph =
    runDoc csharpDoc nameForClass unionName unionPredicate nextNameToTry (S.fromFoldable forbiddenNames) graph unit
    where
        unionPredicate =
            case _ of
            IRUnion ur ->
                let s = unionToSet ur
                in
                    if isNothing $ nullableFromSet s then
                        Just s
                    else
                        Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) =
            csNameStyle $ combineNames names
        nextNameToTry s =
            "Other" <> s

unionName :: List String -> String
unionName s =
    s
    # L.sort
    <#> csNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToCSharp :: Set IRType -> CSDoc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

renderTypeToCSharp :: IRType -> CSDoc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object"
    IRNull -> pure "object"
    IRInteger -> pure "int"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp $ unionToSet types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

csharpDoc :: CSDoc Unit
csharpDoc = do
    line """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
//
//    var data = QuickType.Converter.FromJson(jsonString);
//
namespace QuickType
{"""

    blank
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    line "}"

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderJsonConverter :: CSDoc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions " : JsonConverter" <> " {"
    indent do
        IRGraph { toplevel } <- getGraph
        toplevelType <- renderTypeToCSharp toplevel
        line "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        line
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        when haveUnions do
            blank
            line "public override bool CanConvert(Type t) {"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer) {"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"
            blank
            line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer) {"
            indent $ line "throw new NotImplementedException();"
            line "}"
            blank
            line "public override bool CanWrite { get { return false; } }"
    line "}"

tokenCase :: String -> CSDoc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> CSDoc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            line "break;"

unionFieldName :: IRType -> CSDoc String
unionFieldName t = do
    graph <- getGraph
    let typeName = typeNameForUnion graph t
    pure $ csNameStyle typeName

deserialize :: String -> String -> CSDoc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> CSDoc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> Set IRType -> CSDoc Unit
renderPrimitiveDeserializer tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> CSDoc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRType -> Boolean) -> String -> Set IRType -> CSDoc Unit
renderGenericDeserializer predicate tokenType types = unsafePartial $
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: Set IRType -> CSDoc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ "public struct " <> name <> " {"
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToCSharp $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer) {"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            line "switch (reader.TokenType) {"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool allTypes
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"
    line "}"

renderCSharpClass :: IRClassData -> String -> CSDoc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "public class " <> className
    line "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            let csPropName = lookupName pname propertyNames
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            blank
    line "}"