Make Error card compile

Make Error card compile

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Error.Component
  ( errorCardComponent
  , module SlamData.Workspace.Card.Error.Component.Query
  , module SlamData.Workspace.Card.Error.Component.State
  ) where

import SlamData.Prelude
import SlamData.Monad (Slam)

import SlamData.Workspace.Card.Error.Component.Query (Query, initiality)
import SlamData.Workspace.Card.Error.Component.State (State, initialState)
import SlamData.Render.CSS as CSS

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

type DSL = H.ComponentDSL State Query Void Slam
type HTML = H.ComponentHTML Query

errorCardComponent ∷ H.Component HH.HTML Query Unit Void Slam
errorCardComponent =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → HTML
render st =
  HH.div
    [ HP.classes [ CSS.cardFailures ] ]
    [ HH.text st.message ]

eval ∷ Query ~> DSL
eval = initiality

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Error.Component
  ( errorCardComponent
  , module SlamData.Workspace.Card.Error.Component.Query
  , module SlamData.Workspace.Card.Error.Component.State
  ) where

import SlamData.Prelude
import SlamData.Monad (Slam)

import SlamData.Workspace.Card.Error.Component.Query (Query, initiality)
import SlamData.Workspace.Card.Error.Component.State (State, initialState)
import SlamData.Render.CSS as CSS

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

type DSL = H.ComponentDSL State Query Slam
type HTML = H.ComponentHTML Query

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

render ∷ State → HTML
render st =
  HH.div
    [ HP.classes [ CSS.cardFailures ] ]
    [ HH.text st.message ]

eval ∷ Query ~> DSL
eval = initiality


minor refactor

minor refactor

module IR where

import Data.Maybe
import Data.StrMap

type Int = Number
type Word = Number
type Float = Number
type Int16 = Number
type Int32 = Number
type Word16 = Number
type Word32 = Number
type Bool = Boolean

data V2 a = V2 a a
data V3 a = V3 a a a
data V4 a = V4 a a a a

-- matrices are stored in column major order
type M22F = V2 V2F
type M23F = V3 V2F
type M24F = V4 V2F
type M32F = V2 V3F
type M33F = V3 V3F
type M34F = V4 V3F
type M42F = V2 V4F
type M43F = V3 V4F
type M44F = V4 V4F

type V2F = V2 Float
type V3F = V3 Float
type V4F = V4 Float
type V2I = V2 Int32
type V3I = V3 Int32
type V4I = V4 Int32
type V2U = V2 Word32
type V3U = V3 Word32
type V4U = V4 Word32
type V2B = V2 Bool
type V3B = V3 Bool
type V4B = V4 Bool

-- GPU type value reification, needed for shader codegen
data Value
    = VBool     Bool
    | VV2B      V2B
    | VV3B      V3B
    | VV4B      V4B
    | VWord     Word32
    | VV2U      V2U
    | VV3U      V3U
    | VV4U      V4U
    | VInt      Int32
    | VV2I      V2I
    | VV3I      V3I
    | VV4I      V4I
    | VFloat    Float
    | VV2F      V2F
    | VV3F      V3F
    | VV4F      V4F
    | VM22F     M22F
    | VM23F     M23F
    | VM24F     M24F
    | VM32F     M32F
    | VM33F     M33F
    | VM34F     M34F
    | VM42F     M42F
    | VM43F     M43F
    | VM44F     M44F

data InputType
    = Bool
    | V2B
    | V3B
    | V4B
    | Word
    | V2U
    | V3U
    | V4U
    | Int
    | V2I
    | V3I
    | V4I
    | Float
    | V2F
    | V3F
    | V4F
    | M22F
    | M23F
    | M24F
    | M32F
    | M33F
    | M34F
    | M42F
    | M43F
    | M44F
    -- shadow textures
    | STexture1D
    | STexture2D
    | STextureCube
    | STexture1DArray
    | STexture2DArray
    | STexture2DRect
    -- float textures
    | FTexture1D
    | FTexture2D
    | FTexture3D
    | FTextureCube
    | FTexture1DArray
    | FTexture2DArray
    | FTexture2DMS
    | FTexture2DMSArray
    | FTextureBuffer
    | FTexture2DRect
    -- int textures
    | ITexture1D
    | ITexture2D
    | ITexture3D
    | ITextureCube
    | ITexture1DArray
    | ITexture2DArray
    | ITexture2DMS
    | ITexture2DMSArray
    | ITextureBuffer
    | ITexture2DRect
    -- uint textures
    | UTexture1D
    | UTexture2D
    | UTexture3D
    | UTextureCube
    | UTexture1DArray
    | UTexture2DArray
    | UTexture2DMS
    | UTexture2DMSArray
    | UTextureBuffer
    | UTexture2DRect

data PointSpriteCoordOrigin = LowerLeft | UpperLeft
data PointSize              = PointSize Float | ProgramPointSize
data PolygonOffset          = NoOffset | Offset Float Float
data FrontFace              = CCW | CW
data PolygonMode            = PolygonPoint PointSize | PolygonLine Float | PolygonFill
data ProvokingVertex        = FirstVertex | LastVertex
data CullMode               = CullNone | CullFront FrontFace | CullBack FrontFace
type DepthFunction          = ComparisonFunction
data ComparisonFunction     = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always
data StencilOperation       = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert
data BlendEquation          = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max
data BlendingFactor         = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate
data LogicOperation         = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set

type StencilOps =
    { frontStencilOp    :: StencilOperation -- ^ Used for front faced triangles and other primitives.
    , backStencilOp     :: StencilOperation -- ^ Used for back faced triangles.
    }

data StencilTests = StencilTests StencilTest StencilTest
type StencilTest =
    { stencilComparision    :: ComparisonFunction   -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with.
    , stencilReference      :: Int32                -- ^ The value to compare with the stencil buffer's value.
    , stencilMask           :: Word32               -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer.
    }

-- primitive types
data FetchPrimitive
    = Points
    | Lines
    | Triangles
    | LinesAdjacency
    | TrianglesAdjacency

instance eqFetchPrimitive :: Eq (FetchPrimitive) where
  (==) Points             Points              = true
  (==) Lines              Lines               = true
  (==) Triangles          Triangles           = true
  (==) LinesAdjacency     LinesAdjacency      = true
  (==) TrianglesAdjacency TrianglesAdjacency  = true
  (/=) a                  b                   = not (a == b)

instance showFetchPrimitive :: Show (FetchPrimitive) where
  show Points             = "Points"
  show Lines              = "Lines"
  show Triangles          = "Triangles"
  show LinesAdjacency     = "LinesAdjacency"
  show TrianglesAdjacency = "TrianglesAdjacency"

data OutputPrimitive
    = TrianglesOutput
    | LinesOutput
    | PointsOutput

data ColorArity = Red | RG | RGB | RGBA

type BlendingFactorPair = {src :: BlendingFactor, dst :: BlendingFactor}
data Blending
    = NoBlending
    | BlendLogicOp  LogicOperation
    | Blend         {colorEq :: BlendEquation, alphaEq :: BlendEquation}
                    {colorF :: BlendingFactorPair, alphaF :: BlendingFactorPair}
                    V4F

data RasterContext
    = PointCtx      PointSize Float PointSpriteCoordOrigin
    | LineCtx       Float ProvokingVertex
    | TriangleCtx   CullMode PolygonMode PolygonOffset ProvokingVertex

data FragmentOperation
    = DepthOp       DepthFunction Bool
    | StencilOp     StencilTests StencilOps StencilOps
    | ColorOp       Blending Value

type AccumulationContext =
    { accViewportName   :: Maybe String
    , accOperations     :: [FragmentOperation]
    }

data Image
    = DepthImage    Int Float
    | StencilImage  Int Int32
    | ColorImage    Int Value

data TextureDataType
    = FloatT        ColorArity
    | IntT          ColorArity
    | WordT         ColorArity
    | ShadowT

data TextureType
    = Texture1D     TextureDataType Int
    | Texture2D     TextureDataType Int
    | Texture3D     TextureDataType
    | TextureCube   TextureDataType
    | TextureRect   TextureDataType
    | Texture2DMS   TextureDataType Int Int Bool
    | TextureBuffer TextureDataType

data MipMap
    = Mip           Int Int -- Base level, Max level
    | NoMip
    | AutoMip       Int Int -- Base level, Max level

data Filter
    = Nearest
    | Linear
    | NearestMipmapNearest
    | NearestMipmapLinear
    | LinearMipmapNearest
    | LinearMipmapLinear

data EdgeMode
    = Repeat
    | MirroredRepeat
    | ClampToEdge
    | ClampToBorder

type ProgramName = Int
type TextureName = Int
type SamplerName = Int
type UniformName = String
type SlotName = Int
type FrameBufferComponent = Int
type TextureUnit = Int
type RenderTargetName = Int
type TextureUnitMapping = StrMap TextureUnit

data ImageRef
    = TextureImage  TextureName Int (Maybe Int)  -- Texture name, mip index, array index
    | Framebuffer   ImageSemantic

data ImageSemantic
    = Depth
    | Stencil
    | Color

type ClearImage = {semantic :: ImageSemantic, value :: Value}
data Command
    = SetRasterContext          RasterContext
    | SetAccumulationContext    AccumulationContext
    | SetRenderTarget           RenderTargetName
    | SetProgram                ProgramName --TextureUnitMapping    -- adding texture unit map to set program command seems to be better solution than the current one
    | SetSamplerUniform         UniformName TextureUnit             -- hint: currently the texture unit mapping is encoded with this command
    | SetTexture                TextureUnit TextureName             -- binds texture to the specified texture unit
    | SetSampler                TextureUnit (Maybe SamplerName)     -- binds sampler to the specified texture unit
    | RenderSlot                SlotName
    | ClearRenderTarget         [ClearImage]
    | GenerateMipMap            TextureUnit
    | SaveImage                 FrameBufferComponent ImageRef                            -- from framebuffer component to texture (image)
    | LoadImage                 ImageRef FrameBufferComponent                            -- from texture (image) to framebuffer component

type TextureDescriptor =   -- texture size, type, array, mipmap
    { textureType       :: TextureType
    , textureSize       :: Value
    , textureSemantic   :: ImageSemantic
    , textureSampler    :: SamplerDescriptor
    , textureBaseLevel  :: Int
    , textureMaxLevel   :: Int
    }

type SamplerDescriptor =
    { samplerWrapS          :: EdgeMode
    , samplerWrapT          :: Maybe EdgeMode
    , samplerWrapR          :: Maybe EdgeMode
    , samplerMinFilter      :: Filter
    , samplerMagFilter      :: Filter
    , samplerBorderColor    :: Value
    , samplerMinLod         :: Maybe Float
    , samplerMaxLod         :: Maybe Float
    , samplerLodBias        :: Float
    , samplerCompareFunc    :: Maybe ComparisonFunction
    }

type Parameter = {name::String,ty::InputType}
type Program =   -- AST, input
    { programUniforms   :: StrMap InputType    -- uniform input (value based uniforms only / no textures)
    , programStreams    :: StrMap Parameter  -- vertex shader input attribute name -> (slot attribute name, attribute type)
    , programInTextures :: StrMap InputType               -- all textures (uniform textures and render textures) referenced by the program
    , programOutput     :: [Parameter]
    , vertexShader      :: String
    , geometryShader    :: Maybe String
    , fragmentShader    :: String
    }

type Slot =       -- input, primitive type
    { slotName      :: String
    , slotUniforms  :: StrMap InputType
    , slotStreams   :: StrMap InputType
    , slotPrimitive :: FetchPrimitive
    , slotPrograms  :: [ProgramName]
    }

type TargetItem = {semantic::ImageSemantic,ref::Maybe ImageRef}
type RenderTarget =
    { renderTargets :: [TargetItem] -- render texture or default framebuffer (semantic, render texture for the program output)
    }

type Pipeline =
    { textures      :: [TextureDescriptor]
    , samplers      :: [SamplerDescriptor]
    , targets       :: [RenderTarget]
    , programs      :: [Program]
    , slots         :: [Slot]
    , commands      :: [Command]
    }

module IR where

import Data.Maybe
import Data.StrMap

type Int = Number
type Word = Number
type Float = Number
type Int16 = Number
type Int32 = Number
type Word16 = Number
type Word32 = Number
type Bool = Boolean

data V2 a = V2 a a
data V3 a = V3 a a a
data V4 a = V4 a a a a

-- matrices are stored in column major order
type M22F = V2 V2F
type M23F = V3 V2F
type M24F = V4 V2F
type M32F = V2 V3F
type M33F = V3 V3F
type M34F = V4 V3F
type M42F = V2 V4F
type M43F = V3 V4F
type M44F = V4 V4F

type V2F = V2 Float
type V3F = V3 Float
type V4F = V4 Float
type V2I = V2 Int32
type V3I = V3 Int32
type V4I = V4 Int32
type V2U = V2 Word32
type V3U = V3 Word32
type V4U = V4 Word32
type V2B = V2 Bool
type V3B = V3 Bool
type V4B = V4 Bool

-- GPU type value reification, needed for shader codegen
data Value
    = VBool     Bool
    | VV2B      V2B
    | VV3B      V3B
    | VV4B      V4B
    | VWord     Word32
    | VV2U      V2U
    | VV3U      V3U
    | VV4U      V4U
    | VInt      Int32
    | VV2I      V2I
    | VV3I      V3I
    | VV4I      V4I
    | VFloat    Float
    | VV2F      V2F
    | VV3F      V3F
    | VV4F      V4F
    | VM22F     M22F
    | VM23F     M23F
    | VM24F     M24F
    | VM32F     M32F
    | VM33F     M33F
    | VM34F     M34F
    | VM42F     M42F
    | VM43F     M43F
    | VM44F     M44F

data InputType
    = Bool
    | V2B
    | V3B
    | V4B
    | Word
    | V2U
    | V3U
    | V4U
    | Int
    | V2I
    | V3I
    | V4I
    | Float
    | V2F
    | V3F
    | V4F
    | M22F
    | M23F
    | M24F
    | M32F
    | M33F
    | M34F
    | M42F
    | M43F
    | M44F
    -- shadow textures
    | STexture1D
    | STexture2D
    | STextureCube
    | STexture1DArray
    | STexture2DArray
    | STexture2DRect
    -- float textures
    | FTexture1D
    | FTexture2D
    | FTexture3D
    | FTextureCube
    | FTexture1DArray
    | FTexture2DArray
    | FTexture2DMS
    | FTexture2DMSArray
    | FTextureBuffer
    | FTexture2DRect
    -- int textures
    | ITexture1D
    | ITexture2D
    | ITexture3D
    | ITextureCube
    | ITexture1DArray
    | ITexture2DArray
    | ITexture2DMS
    | ITexture2DMSArray
    | ITextureBuffer
    | ITexture2DRect
    -- uint textures
    | UTexture1D
    | UTexture2D
    | UTexture3D
    | UTextureCube
    | UTexture1DArray
    | UTexture2DArray
    | UTexture2DMS
    | UTexture2DMSArray
    | UTextureBuffer
    | UTexture2DRect

data PointSpriteCoordOrigin = LowerLeft | UpperLeft
data PointSize              = PointSize Float | ProgramPointSize
data PolygonOffset          = NoOffset | Offset Float Float
data FrontFace              = CCW | CW
data PolygonMode            = PolygonPoint PointSize | PolygonLine Float | PolygonFill
data ProvokingVertex        = FirstVertex | LastVertex
data CullMode               = CullNone | CullFront FrontFace | CullBack FrontFace
type DepthFunction          = ComparisonFunction
data ComparisonFunction     = Never | Less | Equal | Lequal | Greater | Notequal | Gequal | Always
data StencilOperation       = OpZero | OpKeep | OpReplace | OpIncr | OpIncrWrap | OpDecr | OpDecrWrap | OpInvert
data BlendEquation          = FuncAdd | FuncSubtract | FuncReverseSubtract | Min | Max
data BlendingFactor         = Zero | One | SrcColor | OneMinusSrcColor | DstColor | OneMinusDstColor | SrcAlpha | OneMinusSrcAlpha | DstAlpha | OneMinusDstAlpha | ConstantColor | OneMinusConstantColor | ConstantAlpha | OneMinusConstantAlpha | SrcAlphaSaturate
data LogicOperation         = Clear | And | AndReverse | Copy | AndInverted | Noop | Xor | Or | Nor | Equiv | Invert | OrReverse | CopyInverted | OrInverted | Nand | Set

type StencilOps =
    { frontStencilOp    :: StencilOperation -- ^ Used for front faced triangles and other primitives.
    , backStencilOp     :: StencilOperation -- ^ Used for back faced triangles.
    }

data StencilTests = StencilTests StencilTest StencilTest
type StencilTest =
    { stencilComparision    :: ComparisonFunction   -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with.
    , stencilReference      :: Int32                -- ^ The value to compare with the stencil buffer's value.
    , stencilMask           :: Word32               -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer.
    }

-- primitive types
data FetchPrimitive
    = Points
    | Lines
    | Triangles
    | LinesAdjacency
    | TrianglesAdjacency

instance eqFetchPrimitive :: Eq (FetchPrimitive) where
  (==) Points             Points              = true
  (==) Lines              Lines               = true
  (==) Triangles          Triangles           = true
  (==) LinesAdjacency     LinesAdjacency      = true
  (==) TrianglesAdjacency TrianglesAdjacency  = true
  (/=) a                  b                   = not (a == b)

instance showFetchPrimitive :: Show (FetchPrimitive) where
  show Points             = "Points"
  show Lines              = "Lines"
  show Triangles          = "Triangles"
  show LinesAdjacency     = "LinesAdjacency"
  show TrianglesAdjacency = "TrianglesAdjacency"

data OutputPrimitive
    = TrianglesOutput
    | LinesOutput
    | PointsOutput

data ColorArity = Red | RG | RGB | RGBA

type BlendingFactorPair = {src :: BlendingFactor, dst :: BlendingFactor}
data Blending
    = NoBlending
    | BlendLogicOp  LogicOperation
    | Blend         {colorEq :: BlendEquation, alphaEq :: BlendEquation}
                    {colorF :: BlendingFactorPair, alphaF :: BlendingFactorPair}
                    V4F

data RasterContext
    = PointCtx      PointSize Float PointSpriteCoordOrigin
    | LineCtx       Float ProvokingVertex
    | TriangleCtx   CullMode PolygonMode PolygonOffset ProvokingVertex

data FragmentOperation
    = DepthOp       DepthFunction Bool
    | StencilOp     StencilTests StencilOps StencilOps
    | ColorOp       Blending Value

type AccumulationContext =
    { accViewportName   :: Maybe String
    , accOperations     :: [FragmentOperation]
    }

data Image
    = DepthImage    Int Float
    | StencilImage  Int Int32
    | ColorImage    Int Value

data TextureDataType
    = FloatT        ColorArity
    | IntT          ColorArity
    | WordT         ColorArity
    | ShadowT

data TextureType
    = Texture1D     TextureDataType Int
    | Texture2D     TextureDataType Int
    | Texture3D     TextureDataType
    | TextureCube   TextureDataType
    | TextureRect   TextureDataType
    | Texture2DMS   TextureDataType Int Int Bool
    | TextureBuffer TextureDataType

data MipMap
    = Mip           Int Int -- Base level, Max level
    | NoMip
    | AutoMip       Int Int -- Base level, Max level

data Filter
    = Nearest
    | Linear
    | NearestMipmapNearest
    | NearestMipmapLinear
    | LinearMipmapNearest
    | LinearMipmapLinear

data EdgeMode
    = Repeat
    | MirroredRepeat
    | ClampToEdge
    | ClampToBorder

type ProgramName = Int
type TextureName = Int
type SamplerName = Int
type UniformName = String
type SlotName = Int
type FrameBufferComponent = Int
type TextureUnit = Int
type RenderTargetName = Int
type TextureUnitMapping = StrMap TextureUnit

data ImageRef
    = TextureImage  TextureName Int (Maybe Int)  -- Texture name, mip index, array index
    | Framebuffer   ImageSemantic

data ImageSemantic
    = Depth
    | Stencil
    | Color

data Command
    = SetRasterContext          RasterContext
    | SetAccumulationContext    AccumulationContext
    | SetRenderTarget           RenderTargetName
    | SetProgram                ProgramName --TextureUnitMapping    -- adding texture unit map to set program command seems to be better solution than the current one
    | SetSamplerUniform         UniformName TextureUnit             -- hint: currently the texture unit mapping is encoded with this command
    | SetTexture                TextureUnit TextureName             -- binds texture to the specified texture unit
    | SetSampler                TextureUnit (Maybe SamplerName)     -- binds sampler to the specified texture unit
    | RenderSlot                SlotName
    | ClearRenderTarget         [{semantic :: ImageSemantic, value :: Value}]
    | GenerateMipMap            TextureUnit
    | SaveImage                 FrameBufferComponent ImageRef                            -- from framebuffer component to texture (image)
    | LoadImage                 ImageRef FrameBufferComponent                            -- from texture (image) to framebuffer component

type TextureDescriptor =   -- texture size, type, array, mipmap
    { textureType       :: TextureType
    , textureSize       :: Value
    , textureSemantic   :: ImageSemantic
    , textureSampler    :: SamplerDescriptor
    , textureBaseLevel  :: Int
    , textureMaxLevel   :: Int
    }

type SamplerDescriptor =
    { samplerWrapS          :: EdgeMode
    , samplerWrapT          :: Maybe EdgeMode
    , samplerWrapR          :: Maybe EdgeMode
    , samplerMinFilter      :: Filter
    , samplerMagFilter      :: Filter
    , samplerBorderColor    :: Value
    , samplerMinLod         :: Maybe Float
    , samplerMaxLod         :: Maybe Float
    , samplerLodBias        :: Float
    , samplerCompareFunc    :: Maybe ComparisonFunction
    }

type Program =   -- AST, input
    { programUniforms   :: StrMap InputType    -- uniform input (value based uniforms only / no textures)
    , programStreams    :: StrMap {name::String,ty::InputType}  -- vertex shader input attribute name -> (slot attribute name, attribute type)
    , programInTextures :: StrMap InputType               -- all textures (uniform textures and render textures) referenced by the program
    , programOutput     :: [{name::String,ty::InputType}]
    , vertexShader      :: String
    , geometryShader    :: Maybe String
    , fragmentShader    :: String
    }

type Slot =       -- input, primitive type
    { slotName      :: String
    , slotUniforms  :: StrMap InputType
    , slotStreams   :: StrMap InputType
    , slotPrimitive :: FetchPrimitive
    , slotPrograms  :: [ProgramName]
    }

type RenderTarget =
    { renderTargets :: [{semantic::ImageSemantic,ref::Maybe ImageRef}] -- render texture or default framebuffer (semantic, render texture for the program output)
    }

type Pipeline =
    { textures      :: [TextureDescriptor]
    , samplers      :: [SamplerDescriptor]
    , targets       :: [RenderTarget]
    , programs      :: [Program]
    , slots         :: [Slot]
    , commands      :: [Command]
    }


Remove unused imports

Remove unused imports

-- | This module defines the `Alternative` type class and associated
-- | helper functions.

module Control.Alternative where

import Prelude

import Control.Plus (Plus)

-- | The `Alternative` type class has no members of its own; it just specifies
-- | that the type constructor has both `Applicative` and `Plus` instances.
-- |
-- | Types which have `Alternative` instances should also satisfy the following
-- | laws:
-- |
-- | - Distributivity: `(f <|> g) <*> x == (f <*> x) <|> (g <*> x)`
-- | - Annihilation: `empty <*> f = empty`
class (Applicative f, Plus f) <= Alternative f

instance alternativeArray :: Alternative Array

-- | This module defines the `Alternative` type class and associated
-- | helper functions.

module Control.Alternative where

import Prelude

import Control.Alt
import Control.Lazy
import Control.Plus

-- | The `Alternative` type class has no members of its own; it just specifies
-- | that the type constructor has both `Applicative` and `Plus` instances.
-- |
-- | Types which have `Alternative` instances should also satisfy the following
-- | laws:
-- |
-- | - Distributivity: `(f <|> g) <*> x == (f <*> x) <|> (g <*> x)`
-- | - Annihilation: `empty <*> f = empty`
class (Applicative f, Plus f) <= Alternative f

instance alternativeArray :: Alternative Array


fix bug in range

fix bug in range

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some
-- TODO
--  , many

  , length

  , (:), cons
  , cons'
  , snoc
  , snoc'
  , appendArray
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

-- TODO
--  , group
--  , group'
--  , groupBy

  , nub
  , nubBy
--  , union
--  , unionBy
  , delete
  , deleteBy

--  , (\\), difference
--  , intersect
--  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

--  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> Maybe (NonEmptyArray Int)
range x y = fromArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

--TODO
--group :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--group' :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--groupBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some
-- TODO
--  , many

  , length

  , (:), cons
  , cons'
  , snoc
  , snoc'
  , appendArray
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

-- TODO
--  , group
--  , group'
--  , groupBy

  , nub
  , nubBy
--  , union
--  , unionBy
  , delete
  , deleteBy

--  , (\\), difference
--  , intersect
--  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

--  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> NonEmptyArray Int
range x y = NonEmptyArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

--TODO
--group :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--group' :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--groupBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex


redundant module removed

redundant module removed

module Data.ExistsR where

import Unsafe.Coerce (unsafeCoerce)

foreign import data ExistsAR ∷ (* → # * → *) → *

mkExistsAR ∷ ∀ a r f. f a r → ExistsAR f
mkExistsAR = unsafeCoerce

runExistsAR ∷ ∀ f t. (∀ a r. f a r → t) → ExistsAR f → t
runExistsAR = unsafeCoerce


Don't create new globals in instantiateAt

When a lambda's body was just a free variable, we were creating a new
global that pointed at the real global. For example, suppose "false"
is at address #1, and we're reducing the input at address #3:

  #1: Global "false" #2
  #2: Closure (λt. λf. f)
  #3: Apply #4 #5 <---------[input]--------> (λa. false) (λb. b)
  #4: Closure (λa. false)
  #5: Closure (λb. b)

We would reduce the input as follows:

  1. (λa. false) (λb. b)
  2. false
  3. false
  4. λt. λf. f

This is because we were instantating the body of the lambda by creating
a new Global:

  #1: Global "false" #2
  #2: Closure (λt. λf. f)
  #3: Global "false" #1

Instead of a new pointer:

  #1: Global "false" #2
  #2: Closure (λt. λf. f)
  #3: Pointer #1

And then we would have to unwind and fetch the global twice. The fix is
to use a Pointer instead (which we correctly keep unwinding through).

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 eqNode :: Eq Node
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 eqStuck :: Eq Stuck
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 $ Pointer 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
  | Pointer Address
  | Stuck Stuck

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

derive instance eqNode :: Eq Node
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 eqStuck :: Eq Stuck
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]


Add missing equality test on SString

Add missing equality test on SString

module Data.Generic
  (Generic, toSpine, toSignature, fromSpine,
   GenericSpine(..),
   GenericSignature(..),
   isValidSpine,
   Proxy(..),
   anyProxy,
   gShow,
   gEq,
   gCompare
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import Data.Foldable (all, and, find)
import Data.Array (null, length, sortBy, zipWith)
import Data.String (joinWith)

-- | A GenericSpine is a universal represntation of an arbitrary data structure (that does not contain function arrows).
data GenericSpine = SProd String (Array (Unit -> GenericSpine))
                  | SRecord (Array {recLabel :: String, recValue :: Unit -> GenericSpine})
                  | SNumber Number
                  | SBoolean Boolean
                  | SInt Int
                  | SString String
                  | SChar Char
                  | SArray (Array (Unit -> GenericSpine))

-- | A GenericSignature is a universal representation of the structure of an arbitrary data structure (that does not contain function arrows).
data GenericSignature = SigProd (Array {sigConstructor :: String, sigValues :: Array (Unit -> GenericSignature)})
                      | SigRecord (Array {recLabel :: String, recValue :: Unit -> GenericSignature})
                      | SigNumber
                      | SigBoolean
                      | SigInt
                      | SigString
                      | SigChar
                      | SigArray (Unit -> GenericSignature)

-- | A proxy is a simple placeholder data type to allow us to pass type-level data at runtime.
data Proxy a = Proxy

anyProxy :: forall a. Proxy a
anyProxy = Proxy

-- | The Generic typeclass provides methods for sending data to/from spine representations, as well as querying about the signatures of spine representations.
-- | For standard data structures, you can simply write "instance Generic Foo" in the module they are declared, and the instance methods will be filled in for you.
class Generic a where
    toSpine :: a -> GenericSpine
    toSignature :: Proxy a -> GenericSignature
    fromSpine :: GenericSpine -> Maybe a

-- | Checks that the spine follows the structure defined by the signature
isValidSpine :: GenericSignature -> GenericSpine -> Boolean
isValidSpine SigBoolean (SBoolean _) = true
isValidSpine SigNumber (SNumber _) = true
isValidSpine SigInt (SInt _) = true
isValidSpine SigString (SString _) = true
isValidSpine SigChar (SChar _) = true
isValidSpine (SigArray sig) (SArray spines) = all (isValidSpine (sig unit) <<< (unit #)) spines
isValidSpine (SigProd alts) (SProd tag values) =
  case find ((tag ==) <<< _.sigConstructor) alts of
    Nothing -> false
    Just { sigValues: sigValues } ->
      and $ zipWith (\sig spine -> isValidSpine (sig unit) (spine unit)) sigValues values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith (\sig val -> isValidSpine (sig.recValue unit) (val.recValue unit))
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine _ _ = false

instance genericNumber :: Generic Number where
    toSpine x = SNumber x
    toSignature _ = SigNumber
    fromSpine (SNumber n) = Just n
    fromSpine _ = Nothing

instance genericInt :: Generic Int where
    toSpine x = SInt x
    toSignature _ = SigInt
    fromSpine (SInt n) = Just n
    fromSpine _ = Nothing

instance genericString :: Generic String where
    toSpine x = SString x
    toSignature _ = SigString
    fromSpine (SString s) = Just s
    fromSpine _ = Nothing

instance genericChar :: Generic Char where
    toSpine x = SChar x
    toSignature _ = SigChar
    fromSpine (SChar s) = Just s
    fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
    toSpine b = SBoolean b
    toSignature _ = SigBoolean
    fromSpine (SBoolean b)  = Just b
    fromSpine _ = Nothing

instance genericArray :: (Generic a) => Generic (Array a) where
    toSpine xs = SArray ((\x y -> toSpine x) <$> xs)
    toSignature x = SigArray (\unit -> toSignature (lowerProxy x))
        where lowerProxy :: Proxy (Array a) -> Proxy a
              lowerProxy Proxy = (anyProxy :: Proxy a)

    fromSpine (SArray x) = traverse (fromSpine <<< ($ unit)) x
    fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
      toSpine (Tuple x y) = SProd "Data.Tuple.Tuple" [\u -> toSpine x, \u -> toSpine y]

      toSignature x = SigProd [{sigConstructor: "Data.Tuple.Tuple", sigValues: [\u -> toSignature (fstProxy x), \u -> toSignature (sndProxy x)]}]
                    where fstProxy :: Proxy (Tuple a b) -> Proxy a
                          fstProxy Proxy = (anyProxy :: Proxy a)
                          sndProxy :: Proxy (Tuple a b) -> Proxy b
                          sndProxy Proxy = (anyProxy :: Proxy b)

      fromSpine (SProd "Data.Tuple.Tuple" [x,y]) = Tuple <$> fromSpine (x unit) <*> fromSpine (y unit)
      fromSpine _ = Nothing

instance genericMaybe :: (Generic a) => Generic (Maybe a) where
      toSpine (Just x) = SProd "Data.Maybe.Just" [\u -> toSpine x]
      toSpine Nothing = SProd "Data.Maybe.Nothing" []
      toSignature x = SigProd [{sigConstructor: "Data.Maybe.Just",sigValues: [\u -> toSignature (mbProxy x)]},
                               {sigConstructor: "Data.Maybe.Nothing",sigValues:[]}]
          where mbProxy :: Proxy (Maybe a) -> Proxy a
                mbProxy Proxy = (anyProxy :: Proxy a)
      fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (x unit)
      fromSpine (SProd "Data.Maybe.Nothing" []) = return Nothing
      fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
    toSpine (Left x) = SProd "Data.Either.Left" [\u -> toSpine x]
    toSpine (Right x) = SProd "Data.Either.Right" [\u -> toSpine x]
    toSignature x = SigProd [{sigConstructor: "Data.Either.Left",  sigValues: [\u -> toSignature (lproxy x)]},
                             {sigConstructor: "Data.Either.Right", sigValues: [\u -> toSignature (rproxy x)]}]
          where lproxy :: Proxy (Either a b) -> Proxy a
                lproxy Proxy = (anyProxy :: Proxy a)
                rproxy :: Proxy (Either a b) -> Proxy b
                rproxy Proxy = (anyProxy :: Proxy b)
    fromSpine (SProd "Data.Either.Left"  [x]) = Left  <$> fromSpine (x unit)
    fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (x unit)
    fromSpine _ = Nothing

--- Generic Functions
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) <> "]"

-- | This function can be used as the default instance for Show for any instance of Generic
gShow :: forall a. (Generic a) => a -> String
gShow = genericShowPrec 0 <<< toSpine

foreign import zipAll :: forall a b c. (a -> b -> Boolean) -> Array a -> Array b -> Boolean

instance eqGeneric :: Eq GenericSpine where
    eq (SProd s1 arr1) (SProd s2 arr2) = s1 == s2
                                      && length arr1 == length arr2
                                      && zipAll (\x y -> x unit == y unit) arr1 arr2
    eq (SRecord xs) (SRecord ys) = length xs == length ys && zipAll go xs ys
             where go x y = x.recLabel == y.recLabel && x.recValue unit == y.recValue unit
    eq (SInt x)     (SInt y)     = x == y
    eq (SNumber x)  (SNumber y)  = x == y
    eq (SBoolean x) (SBoolean y) = x == y
    eq (SChar x)    (SChar y)    = x == y
    eq (SString x)  (SString y)  = x == y
    eq (SArray xs)  (SArray ys)  = length xs == length ys && zipAll (\x y -> x unit == y unit) xs ys
    eq _ _ = false

-- | This function can be used as the default instance for Eq for any instance of Generic
gEq :: forall a. (Generic a) => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

foreign import zipCompare :: forall a b c. (a -> b -> Int) -> Array a -> Array b -> Int

instance ordGeneric :: Ord GenericSpine where
    compare (SProd s1 arr1) (SProd s2 arr2) =
        case compare s1 s2 of
          EQ -> compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                  EQ -> 0
                                                  LT -> 1
                                                  GT -> -1) arr1 arr2
          c1 -> c1
    compare (SProd _ _) _ = LT
    compare _ (SProd _ _) = GT
    compare (SRecord xs) (SRecord ys) = compare 0 $ zipCompare go xs ys
        where go x y = case compare x.recLabel y.recLabel of
                         EQ -> case compare (x.recValue unit) (y.recValue unit) of
                                 EQ -> 0
                                 LT -> 1
                                 GT -> -1
                         LT -> 1
                         GT -> -1
    compare (SRecord _) _ = LT
    compare _ (SRecord _) = GT
    compare (SInt x) (SInt y) = compare x y
    compare (SInt _) _ = LT
    compare _ (SInt _) = GT
    compare (SBoolean x) (SBoolean y) = compare x y
    compare (SBoolean _) _ = LT
    compare _ (SBoolean _) = GT
    compare (SNumber x) (SNumber y) = compare x y
    compare (SNumber _) _ = LT
    compare _ (SNumber _) = GT
    compare (SString x) (SString y) = compare x y
    compare (SString _) _ = LT
    compare _ (SString _) = GT
    compare (SChar x) (SChar y) = compare x y
    compare (SChar _) _ = LT
    compare _ (SChar _) = GT
    compare (SArray xs) (SArray ys) = compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                                        EQ -> 0
                                                                        LT -> 1
                                                                        GT -> -1) xs ys

-- | This function can be used as the default instance for the compare method of Ord for any instance of Generic
gCompare :: forall a. (Generic a) => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)

module Data.Generic
  (Generic, toSpine, toSignature, fromSpine,
   GenericSpine(..),
   GenericSignature(..),
   isValidSpine,
   Proxy(..),
   anyProxy,
   gShow,
   gEq,
   gCompare
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import Data.Foldable (all, and, find)
import Data.Array (null, length, sortBy, zipWith)
import Data.String (joinWith)

-- | A GenericSpine is a universal represntation of an arbitrary data structure (that does not contain function arrows).
data GenericSpine = SProd String (Array (Unit -> GenericSpine))
                  | SRecord (Array {recLabel :: String, recValue :: Unit -> GenericSpine})
                  | SNumber Number
                  | SBoolean Boolean
                  | SInt Int
                  | SString String
                  | SChar Char
                  | SArray (Array (Unit -> GenericSpine))

-- | A GenericSignature is a universal representation of the structure of an arbitrary data structure (that does not contain function arrows).
data GenericSignature = SigProd (Array {sigConstructor :: String, sigValues :: Array (Unit -> GenericSignature)})
                      | SigRecord (Array {recLabel :: String, recValue :: Unit -> GenericSignature})
                      | SigNumber
                      | SigBoolean
                      | SigInt
                      | SigString
                      | SigChar
                      | SigArray (Unit -> GenericSignature)

-- | A proxy is a simple placeholder data type to allow us to pass type-level data at runtime.
data Proxy a = Proxy

anyProxy :: forall a. Proxy a
anyProxy = Proxy

-- | The Generic typeclass provides methods for sending data to/from spine representations, as well as querying about the signatures of spine representations.
-- | For standard data structures, you can simply write "instance Generic Foo" in the module they are declared, and the instance methods will be filled in for you.
class Generic a where
    toSpine :: a -> GenericSpine
    toSignature :: Proxy a -> GenericSignature
    fromSpine :: GenericSpine -> Maybe a

-- | Checks that the spine follows the structure defined by the signature
isValidSpine :: GenericSignature -> GenericSpine -> Boolean
isValidSpine SigBoolean (SBoolean _) = true
isValidSpine SigNumber (SNumber _) = true
isValidSpine SigInt (SInt _) = true
isValidSpine SigString (SString _) = true
isValidSpine SigChar (SChar _) = true
isValidSpine (SigArray sig) (SArray spines) = all (isValidSpine (sig unit) <<< (unit #)) spines
isValidSpine (SigProd alts) (SProd tag values) =
  case find ((tag ==) <<< _.sigConstructor) alts of
    Nothing -> false
    Just { sigValues: sigValues } ->
      and $ zipWith (\sig spine -> isValidSpine (sig unit) (spine unit)) sigValues values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith (\sig val -> isValidSpine (sig.recValue unit) (val.recValue unit))
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine _ _ = false

instance genericNumber :: Generic Number where
    toSpine x = SNumber x
    toSignature _ = SigNumber
    fromSpine (SNumber n) = Just n
    fromSpine _ = Nothing

instance genericInt :: Generic Int where
    toSpine x = SInt x
    toSignature _ = SigInt
    fromSpine (SInt n) = Just n
    fromSpine _ = Nothing

instance genericString :: Generic String where
    toSpine x = SString x
    toSignature _ = SigString
    fromSpine (SString s) = Just s
    fromSpine _ = Nothing

instance genericChar :: Generic Char where
    toSpine x = SChar x
    toSignature _ = SigChar
    fromSpine (SChar s) = Just s
    fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
    toSpine b = SBoolean b
    toSignature _ = SigBoolean
    fromSpine (SBoolean b)  = Just b
    fromSpine _ = Nothing

instance genericArray :: (Generic a) => Generic (Array a) where
    toSpine xs = SArray ((\x y -> toSpine x) <$> xs)
    toSignature x = SigArray (\unit -> toSignature (lowerProxy x))
        where lowerProxy :: Proxy (Array a) -> Proxy a
              lowerProxy Proxy = (anyProxy :: Proxy a)

    fromSpine (SArray x) = traverse (fromSpine <<< ($ unit)) x
    fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
      toSpine (Tuple x y) = SProd "Data.Tuple.Tuple" [\u -> toSpine x, \u -> toSpine y]

      toSignature x = SigProd [{sigConstructor: "Data.Tuple.Tuple", sigValues: [\u -> toSignature (fstProxy x), \u -> toSignature (sndProxy x)]}]
                    where fstProxy :: Proxy (Tuple a b) -> Proxy a
                          fstProxy Proxy = (anyProxy :: Proxy a)
                          sndProxy :: Proxy (Tuple a b) -> Proxy b
                          sndProxy Proxy = (anyProxy :: Proxy b)

      fromSpine (SProd "Data.Tuple.Tuple" [x,y]) = Tuple <$> fromSpine (x unit) <*> fromSpine (y unit)
      fromSpine _ = Nothing

instance genericMaybe :: (Generic a) => Generic (Maybe a) where
      toSpine (Just x) = SProd "Data.Maybe.Just" [\u -> toSpine x]
      toSpine Nothing = SProd "Data.Maybe.Nothing" []
      toSignature x = SigProd [{sigConstructor: "Data.Maybe.Just",sigValues: [\u -> toSignature (mbProxy x)]},
                               {sigConstructor: "Data.Maybe.Nothing",sigValues:[]}]
          where mbProxy :: Proxy (Maybe a) -> Proxy a
                mbProxy Proxy = (anyProxy :: Proxy a)
      fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (x unit)
      fromSpine (SProd "Data.Maybe.Nothing" []) = return Nothing
      fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
    toSpine (Left x) = SProd "Data.Either.Left" [\u -> toSpine x]
    toSpine (Right x) = SProd "Data.Either.Right" [\u -> toSpine x]
    toSignature x = SigProd [{sigConstructor: "Data.Either.Left",  sigValues: [\u -> toSignature (lproxy x)]},
                             {sigConstructor: "Data.Either.Right", sigValues: [\u -> toSignature (rproxy x)]}]
          where lproxy :: Proxy (Either a b) -> Proxy a
                lproxy Proxy = (anyProxy :: Proxy a)
                rproxy :: Proxy (Either a b) -> Proxy b
                rproxy Proxy = (anyProxy :: Proxy b)
    fromSpine (SProd "Data.Either.Left"  [x]) = Left  <$> fromSpine (x unit)
    fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (x unit)
    fromSpine _ = Nothing

--- Generic Functions
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) <> "]"

-- | This function can be used as the default instance for Show for any instance of Generic
gShow :: forall a. (Generic a) => a -> String
gShow = genericShowPrec 0 <<< toSpine

foreign import zipAll :: forall a b c. (a -> b -> Boolean) -> Array a -> Array b -> Boolean

instance eqGeneric :: Eq GenericSpine where
    eq (SProd s1 arr1) (SProd s2 arr2) = s1 == s2
                                      && length arr1 == length arr2
                                      && zipAll (\x y -> x unit == y unit) arr1 arr2
    eq (SRecord xs) (SRecord ys) = length xs == length ys && zipAll go xs ys
             where go x y = x.recLabel == y.recLabel && x.recValue unit == y.recValue unit
    eq (SInt x)     (SInt y)     = x == y
    eq (SNumber x)  (SNumber y)  = x == y
    eq (SBoolean x) (SBoolean y) = x == y
    eq (SChar x)    (SChar y)    = x == y
    eq (SArray xs)  (SArray ys)  = length xs == length ys && zipAll (\x y -> x unit == y unit) xs ys
    eq _ _ = false

-- | This function can be used as the default instance for Eq for any instance of Generic
gEq :: forall a. (Generic a) => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

foreign import zipCompare :: forall a b c. (a -> b -> Int) -> Array a -> Array b -> Int

instance ordGeneric :: Ord GenericSpine where
    compare (SProd s1 arr1) (SProd s2 arr2) =
        case compare s1 s2 of
          EQ -> compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                  EQ -> 0
                                                  LT -> 1
                                                  GT -> -1) arr1 arr2
          c1 -> c1
    compare (SProd _ _) _ = LT
    compare _ (SProd _ _) = GT
    compare (SRecord xs) (SRecord ys) = compare 0 $ zipCompare go xs ys
        where go x y = case compare x.recLabel y.recLabel of
                         EQ -> case compare (x.recValue unit) (y.recValue unit) of
                                 EQ -> 0
                                 LT -> 1
                                 GT -> -1
                         LT -> 1
                         GT -> -1
    compare (SRecord _) _ = LT
    compare _ (SRecord _) = GT
    compare (SInt x) (SInt y) = compare x y
    compare (SInt _) _ = LT
    compare _ (SInt _) = GT
    compare (SBoolean x) (SBoolean y) = compare x y
    compare (SBoolean _) _ = LT
    compare _ (SBoolean _) = GT
    compare (SNumber x) (SNumber y) = compare x y
    compare (SNumber _) _ = LT
    compare _ (SNumber _) = GT
    compare (SString x) (SString y) = compare x y
    compare (SString _) _ = LT
    compare _ (SString _) = GT
    compare (SChar x) (SChar y) = compare x y
    compare (SChar _) _ = LT
    compare _ (SChar _) = GT
    compare (SArray xs) (SArray ys) = compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                                        EQ -> 0
                                                                        LT -> 1
                                                                        GT -> -1) xs ys

-- | This function can be used as the default instance for the compare method of Ord for any instance of Generic
gCompare :: forall a. (Generic a) => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)


indent

indent

module Example.Four where

import Prelude
import Data.Tuple
import Data.Either
import Data.Functor.Coproduct
import Data.Array
import Control.Plus (Plus)

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

import qualified Example.Counter as CC
import qualified Example.CounterRem as Counter
import Example.Two (CounterSlot(..))
import Example.Three (State(..), addCounter, initialState)

data Input a = AddCounter a

listRemUI :: forall g p. (Functor g)
          => ParentComponentP State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
listRemUI = component' render eval peek
    where
        render :: Render State Input CounterSlot
        render state =
            H.div_ [ H.h1_ [ H.text "Counters" ]
                   , H.ul_ (map (H.slot <<< CounterSlot) state.counterArray)
                   , H.button [ E.onClick $ E.input_ AddCounter ]
                              [ H.text "Add Counter" ]
                   ]

        eval :: EvalP Input State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
        eval (AddCounter next) = do
            modify addCounter
            pure next

        peek :: Peek State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
        peek (ChildF counterSlot queryAction) =
            case runCoproduct queryAction of
                 Left (Counter.Remove _) ->
                     modify (removeCounter counterSlot)
                 _ ->
                     pure unit

removeCounter :: CounterSlot -> State -> State
removeCounter (CounterSlot index) state =
    state { counterArray = filter (/= index) state.counterArray }

ui :: forall g p. (Plus g)
   => InstalledComponent State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
ui = install' listRemUI mkCounter
    where
        mkCounter :: CounterSlot -> Tuple (ComponentP _ _ g _ _) _
        mkCounter (CounterSlot _) =
            createChild Counter.ui (installedState unit)

module Example.Four where

import Prelude
import Data.Tuple
import Data.Either
import Data.Functor.Coproduct
import Data.Array
import Control.Plus (Plus)

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

import qualified Example.Counter as CC
import qualified Example.CounterRem as Counter
import Example.Two (CounterSlot(..))
import Example.Three (State(..), addCounter, initialState)

data Input a = AddCounter a

listRemUI :: forall g p. (Functor g)
          => ParentComponentP State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
listRemUI = component' render eval peek
    where
        render :: Render State Input CounterSlot
        render state =
            H.div_ [ H.h1_ [ H.text "Counters" ]
                   , H.ul_ (map (H.slot <<< CounterSlot) state.counterArray)
                   , H.button [ E.onClick $ E.input_ AddCounter ]
                              [ H.text "Add Counter" ]
                   ]

        eval :: EvalP Input State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
        eval (AddCounter next) = do
            modify addCounter
            pure next

        peek :: Peek State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
        peek (ChildF counterSlot queryAction) =
            case runCoproduct queryAction of
                 Left (Counter.Remove _) ->
                    modify $ removeCounter counterSlot
                 _ ->
                    pure unit

removeCounter :: CounterSlot -> State -> State
removeCounter (CounterSlot index) state =
    state { counterArray = filter (/= index) state.counterArray }

ui :: forall g p. (Plus g)
   => InstalledComponent State (Counter.StateMiddle g p) Input Counter.QueryMiddle g CounterSlot p
ui = install' listRemUI mkCounter
    where
        mkCounter :: CounterSlot -> Tuple (ComponentP _ _ g _ _) _
        mkCounter (CounterSlot _) =
            createChild Counter.ui (installedState unit)


Fix mount dialog to show config for Spark/HDFS (#1273)

Resolves #1272

{-
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.FileSystem.Dialog.Mount.Scheme where

import SlamData.Prelude

data Scheme
  = MongoDB
  | SQL2
  | Couchbase
  | MarkLogic
  | SparkHDFS

derive instance eqScheme ∷ Eq Scheme

derive instance ordScheme ∷ Ord Scheme

schemeToString :: Scheme -> String
schemeToString MongoDB = "MongoDB"
schemeToString SQL2 = "SQL²"
schemeToString Couchbase = "Couchbase"
schemeToString MarkLogic = "MarkLogic"
schemeToString SparkHDFS = "HDFS on Spark"

schemeFromString :: String -> Maybe Scheme
schemeFromString "MongoDB" = Just MongoDB
schemeFromString "SQL²" = Just SQL2
schemeFromString "Couchbase" = Just Couchbase
schemeFromString "MarkLogic" = Just MarkLogic
schemeFromString "HDFS on Spark" = Just SparkHDFS
schemeFromString _ = Nothing

schemes :: Array Scheme
schemes =
  [ MongoDB
  , SQL2
  , Couchbase
  , MarkLogic
  , SparkHDFS
  ]

{-
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.FileSystem.Dialog.Mount.Scheme where

import SlamData.Prelude

data Scheme
  = MongoDB
  | SQL2
  | Couchbase
  | MarkLogic
  | SparkHDFS

derive instance eqScheme ∷ Eq Scheme

derive instance ordScheme ∷ Ord Scheme

schemeToString :: Scheme -> String
schemeToString MongoDB = "MongoDB"
schemeToString SQL2 = "SQL²"
schemeToString Couchbase = "Couchbase"
schemeToString MarkLogic = "MarkLogic"
schemeToString SparkHDFS = "HDFS on Spark"

schemeFromString :: String -> Maybe Scheme
schemeFromString "MongoDB" = Just MongoDB
schemeFromString "SQL²" = Just SQL2
schemeFromString "Couchbase" = Just Couchbase
schemeFromString "MarkLogic" = Just MarkLogic
schemeFromString "SparkHDFS" = Just SparkHDFS
schemeFromString _ = Nothing

schemes :: Array Scheme
schemes =
  [ MongoDB
  , SQL2
  , Couchbase
  , MarkLogic
  , SparkHDFS
  ]


Fix bug where 'foo' and '--foo' resolve same key

module Language.Docopt.Trans.Key (
    key
  , toKeys
  , Key(..)
  ) where

import Prelude
import Data.Maybe (maybe)
import Data.String (fromChar)
import Data.String (toUpper, toLower) as Str
import Data.Function (on)
import Data.String.Ext ((^=))
import Language.Docopt.Argument (Argument(..)) as D
newtype Key = Key { arg :: D.Argument }

instance showKey :: Show Key where
  show (Key { arg: (D.Option o) }) =
    maybe "" (\c -> "-"  <> fromChar c <> ", ") o.flag <>
    maybe "" (\n -> "--" <> n)                  o.name
  show (Key { arg: (D.Positional pos) }) = pos.name
  show (Key { arg: (D.Command cmd) })    = cmd.name
  show _                                 = "invalid" -- XXX

instance ordKey :: Ord Key where
  compare = compare `on` show -- XXX

instance eqKey :: Eq Key where
  eq (Key { arg: arg0 }) (Key { arg: arg1 }) = go arg0 arg1
    where
      go (D.Command    cmd) (D.Command    cmd') = cmd.name == cmd'.name
      go (D.Positional pos) (D.Positional pos') = pos.name ^= pos'.name
      go (D.Option { flag = f,  name = n  })
         (D.Option { flag = f', name = n' })
         = (f == f') && (n == n')
      go a b = a == b

key :: D.Argument -> Key
key arg = Key { arg: arg }

-- | Derive a key from an argument.
-- | This key is what the user will use to check the value of
-- | a mathed argument.
toKeys :: D.Argument -> Array String
toKeys (D.Command cmd)    = [ cmd.name ]
toKeys (D.Positional pos) = [ pos.name ]
toKeys (D.Group _)        = []
toKeys (D.EOA)            = ["--"]
toKeys (D.Stdin)          = ["-"]
toKeys (D.Option o)       = []
                          <> maybe [] (\c -> [ "-"  <> fromChar c ]) o.flag
                          <> maybe [] (\s -> [ "--" <> s ]) o.name

module Language.Docopt.Trans.Key (
    key
  , toKeys
  , Key(..)
  ) where

import Prelude
import Data.Maybe (maybe)
import Data.String (fromChar)
import Data.String (toUpper, toLower) as Str
import Data.Function (on)
import Data.String.Ext ((^=))
import Language.Docopt.Argument (Argument(..)) as D
newtype Key = Key { arg :: D.Argument }

instance showKey :: Show Key where
  show (Key { arg: (D.Option o) }) =
    maybe "" (\c -> fromChar c <> ", ") o.flag
      <> maybe "" id o.name
  show (Key { arg: (D.Positional pos) }) = pos.name
  show (Key { arg: (D.Command cmd) })    = cmd.name
  show _                                 = "invalid" -- XXX

instance ordKey :: Ord Key where
  compare = compare `on` show -- XXX

instance eqKey :: Eq Key where
  eq (Key { arg: arg0 }) (Key { arg: arg1 }) = go arg0 arg1
    where
      go (D.Command    cmd) (D.Command    cmd') = cmd.name == cmd'.name
      go (D.Positional pos) (D.Positional pos') = pos.name ^= pos'.name
      go (D.Option { flag = f,  name = n  })
         (D.Option { flag = f', name = n' })
         = (f == f') && (n == n')
      go a b = a == b

key :: D.Argument -> Key
key arg = Key { arg: arg }

-- | Derive a key from an argument.
-- | This key is what the user will use to check the value of
-- | a mathed argument.
toKeys :: D.Argument -> Array String
toKeys (D.Command cmd)    = [ cmd.name ]
toKeys (D.Positional pos) = [ pos.name ]
toKeys (D.Group _)        = []
toKeys (D.EOA)            = ["--"]
toKeys (D.Stdin)          = ["-"]
toKeys (D.Option o)       = []
                          <> maybe [] (\c -> [ "-"  <> fromChar c ]) o.flag
                          <> maybe [] (\s -> [ "--" <> s ]) o.name


Ooops. Fixed endless recursion.

Ooops. Fixed endless recursion.

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

-- | Just use the robust JSON format.
gDefaultEncodeHeader :: forall a. Generic a => a -> URLPiece
gDefaultEncodeHeader v =
  case toSpine v of
    SString s -> s -- Special case string - just use it as is (http-api-data compatibility).
    _ -> show <<< Aeson.encode $ v

-- | 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)
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 = gDefaultEncodeHeader

-- | Just use the robust JSON format.
gDefaultEncodeHeader :: forall a. Generic a => a -> URLPiece
gDefaultEncodeHeader v =
  case toSpine v of
    SString s -> s -- Special case string - just use it as is (http-api-data compatibility).
    _ -> gDefaultToURLPiece $ v

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