Make Listing Item component compile

Make Listing Item component 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.FileSystem.Listing.Item.Component where

import SlamData.Prelude

import Data.Lens (Lens', lens, (%~), (.~))

import Halogen as H
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import DOM.Event.Types (MouseEvent, mouseEventToEvent)
import DOM.Event.Event (preventDefault)

import SlamData.Monad (Slam)
import SlamData.FileSystem.Listing.Item (Item(..), itemResource)
import SlamData.FileSystem.Listing.Item.Component.CSS as CSS
import SlamData.FileSystem.Resource (Resource(..), Mount(..), resourceName, resourcePath, isMount, isFile, isWorkspace, isViewMount, hiddenTopLevel, root)

type State =
  { item ∷ Item
  , isSearching ∷ Boolean
  , isHidden ∷ Boolean
  }

initialState ∷ State
initialState =
  { item: PhantomItem root
  , isSearching: false
  , isHidden: false
  }

_item ∷ Lens' State Item
_item = lens _.item _{item = _}

_isSearching ∷ Lens' State Boolean
_isSearching = lens _.isSearching _{isSearching = _}

_isHidden ∷ Lens' State Boolean
_isHidden = lens _.isHidden _{isHidden = _}

data Query a
  = Toggle a
  | PresentActions a
  | HideActions a
  | Deselect a
  | HandleAction Message MouseEvent a
  | SetIsSearching Boolean a
  | SetIsHidden Boolean a

data Message
  = Open Resource
  | Configure Resource
  | Move Resource
  | Download Resource
  | Remove Resource
  | Share Resource

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

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

render ∷ State → HTML
render state = case state.item of
  SelectedItem _ → itemView state true true
  ActionsPresentedItem _ → itemView state false true
  Item _ → itemView state false false
  PhantomItem _ →
    HH.div
      [ HP.classes [ B.listGroupItem, CSS.phantom ] ]
      [ HH.div
          [ HP.class_ B.row ]
          [ HH.div
              [ HP.classes [ B.colXs8, CSS.itemContent ] ]
              [ HH.span_
                  [ HH.img [ HP.src "img/spin.gif" ]
                  , HH.text $ itemName state
                  ]
              ]
          ]
      ]

eval ∷ Query ~> DSL
eval (Toggle next) = H.modify (_item %~ toggle) $> next
  where
  toggle (Item r) = SelectedItem r
  toggle (ActionsPresentedItem r) = SelectedItem r
  toggle (SelectedItem r) = Item r
  toggle it = it
eval (Deselect next) = H.modify (_item %~ deselect) $> next
  where
  deselect (SelectedItem r) = Item r
  deselect it = it
eval (PresentActions next) = H.modify (_item %~ presentActions) $> next
  where
  presentActions (Item r) = ActionsPresentedItem r
  presentActions it = it
eval (HideActions next) = H.modify (_item %~ hideActions) $> next
  where
  hideActions (ActionsPresentedItem r) = Item r
  hideActions it = it
eval (HandleAction msg ev next) = do
  H.liftEff $ preventDefault (mouseEventToEvent ev)
  H.raise msg
  pure next
eval (SetIsSearching bool next) = H.modify (_isSearching .~ bool) $> next
eval (SetIsHidden bool next) = H.modify (_isHidden .~ bool) $> next

itemName ∷ State → String
itemName { isSearching, item } =
  let toName = if isSearching then resourcePath else resourceName
  in toName $ itemResource item

itemIsHidden ∷ Item → Boolean
itemIsHidden = hiddenTopLevel <<< itemResource

presentHiddenItem ∷ State → Boolean
presentHiddenItem = not <<< _.isHidden

presentItem ∷ State → Item → Boolean
presentItem state item = (isHidden && presentHiddenItem state) || not isHidden
  where
  isHidden = itemIsHidden item

itemView ∷ State → Boolean → Boolean → HTML
itemView state@{ item } selected presentActions | not (presentItem state item) =
  HH.text ""
itemView state@{ item } selected presentActions | otherwise =
  HH.div
    [ HP.classes itemClasses
    , HE.onClick (HE.input_ Toggle)
    , HE.onMouseEnter (HE.input_ PresentActions)
    , HE.onMouseLeave (HE.input_ HideActions)
    , HE.onDoubleClick $ HE.input $ HandleAction (Open (itemResource item))
    , ARIA.label label
    ]
    [ HH.div
        [ HP.class_ B.row ]
        [ HH.div
            [ HP.classes [ B.colXs8, CSS.itemContent ] ]
            [ HH.a
                [ HE.onClick $ HE.input $ HandleAction (Open (itemResource item)) ]
                [ HH.i [ iconClasses item ] []
                , HH.text $ itemName state
                ]
            ]
        , HH.div
            [ HP.classes $ [ B.colXs4, CSS.itemToolbar ] ⊕ (guard selected $> CSS.selected) ]
            [ itemActions presentActions item ]
        ]
    ]
  where
  itemClasses ∷ Array HH.ClassName
  itemClasses =
    [ B.listGroupItem ]
    ⊕ (guard selected $> B.listGroupItemInfo)
    ⊕ (if itemIsHidden item && presentHiddenItem state then [ CSS.itemHidden ] else [ ])

  label ∷ String
  label | selected  = "Deselect " <> itemName state
  label | otherwise = "Select " <> itemName state

iconClasses ∷ forall i r. Item → HP.IProp (class ∷ String | r) i
iconClasses item = HP.classes
  [ B.glyphicon
  , CSS.itemIcon
  , iconClass (itemResource item)
  ]
  where
  iconClass ∷ Resource → HH.ClassName
  iconClass (File _) = B.glyphiconFile
  iconClass (Workspace _) = B.glyphiconBook
  iconClass (Directory _) = B.glyphiconFolderOpen
  iconClass (Mount (Database _)) = B.glyphiconHdd
  iconClass (Mount (View _)) = B.glyphiconFile

itemActions ∷ Boolean → Item → HTML
itemActions presentActions item | not presentActions = HH.text ""
itemActions presentActions item | otherwise =
  HH.ul
    [ HP.classes [ B.listInline, B.pullRight ]
    , HCSS.style $ marginBottom (px zero)
    ]
    (conf ⊕ common ⊕ share)
  where
  r ∷ Resource
  r = itemResource item

  conf ∷ Array HTML
  conf = guard (isMount r) $>
    itemAction Configure "Configure" B.glyphiconWrench

  common ∷ Array HTML
  common =
    [
      itemAction Move "Move / rename" B.glyphiconMove
    , itemAction Download "Download" B.glyphiconCloudDownload
    , itemAction Remove "Remove" B.glyphiconTrash
    ]

  share ∷ Array HTML
  share = guard (isFile r || isWorkspace r || isViewMount r) $>
    itemAction Share "Share" B.glyphiconShare

  itemAction ∷ (Resource → Message) → String → HH.ClassName → HTML
  itemAction act label cls =
    HH.li_
      [ HH.button
          [ HE.onClick $ HE.input $ HandleAction $ act (itemResource item)
          , HP.title label
          , ARIA.label label
          , HP.class_ CSS.fileAction
          ]
          [ HH.i [ HP.classes [ B.glyphicon, cls ] ] [] ]
      ]

{-
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.Listing.Item.Component where

import SlamData.Prelude

import Data.Lens (Lens', lens, (%~), (.~))

import Halogen as H
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import SlamData.Monad (Slam)
import SlamData.FileSystem.Listing.Item (Item(..), itemResource)
import SlamData.FileSystem.Listing.Item.Component.CSS as CSS
import SlamData.FileSystem.Resource (Resource(..), Mount(..), resourceName, resourcePath, isMount, isFile, isWorkspace, isViewMount, hiddenTopLevel, root)

type State =
  { item ∷ Item
  , isSearching ∷ Boolean
  , isHidden ∷ Boolean
  }

initialState ∷ State
initialState =
  { item: PhantomItem root
  , isSearching: false
  , isHidden: false
  }

_item ∷ Lens' State Item
_item = lens _.item _{item = _}

_isSearching ∷ Lens' State Boolean
_isSearching = lens _.isSearching _{isSearching = _}

_isHidden ∷ Lens' State Boolean
_isHidden = lens _.isHidden _{isHidden = _}

data Query a
  = Toggle a
  | PresentActions a
  | HideActions a
  | Deselect a
  | Open Resource a
  | Configure Resource a
  | Move Resource a
  | Download Resource a
  | Remove Resource a
  | Share Resource a
  | SetIsSearching Boolean a
  | SetIsHidden Boolean a

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

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

render ∷ State → HTML
render state = case state.item of
  SelectedItem _ → itemView state true true
  ActionsPresentedItem _ → itemView state false true
  Item _ → itemView state false false
  PhantomItem _ →
    HH.div
      [ HP.classes [ B.listGroupItem, CSS.phantom ] ]
      [ HH.div
          [ HP.class_ B.row ]
          [ HH.div
              [ HP.classes [ B.colXs8, CSS.itemContent ] ]
              [ HH.span_
                  [ HH.img [ HP.src "img/spin.gif" ]
                  , HH.text $ itemName state
                  ]
              ]
          ]
      ]

eval ∷ Query ~> DSL
eval (Toggle next) = H.modify (_item %~ toggle) $> next
  where
  toggle (Item r) = SelectedItem r
  toggle (ActionsPresentedItem r) = SelectedItem r
  toggle (SelectedItem r) = Item r
  toggle it = it
eval (Deselect next) = H.modify (_item %~ deselect) $> next
  where
  deselect (SelectedItem r) = Item r
  deselect it = it
eval (PresentActions next) = H.modify (_item %~ presentActions) $> next
  where
  presentActions (Item r) = ActionsPresentedItem r
  presentActions it = it
eval (HideActions next) = H.modify (_item %~ hideActions) $> next
  where
  hideActions (ActionsPresentedItem r) = Item r
  hideActions it = it
eval (Open _ next) = pure next
eval (Configure _ next) = pure next
eval (Move _ next) = pure next
eval (Download _ next) = pure next
eval (Remove _ next) = pure next
eval (Share _ next) = pure next
eval (SetIsSearching bool next) = H.modify (_isSearching .~ bool) $> next
eval (SetIsHidden bool next) = H.modify (_isHidden .~ bool) $> next

itemName ∷ State → String
itemName { isSearching, item } =
  let toName = if isSearching then resourcePath else resourceName
  in toName $ itemResource item

itemIsHidden ∷ Item → Boolean
itemIsHidden = hiddenTopLevel <<< itemResource

presentHiddenItem ∷ State → Boolean
presentHiddenItem = not <<< _.isHidden

presentItem ∷ State → Item → Boolean
presentItem state item = (isHidden && presentHiddenItem state) || not isHidden
  where
  isHidden = itemIsHidden item

itemView ∷ State → Boolean → Boolean → HTML
itemView state@{ item } selected presentActions | not (presentItem state item) =
  HH.text ""
itemView state@{ item } selected presentActions | otherwise =
  HH.div
    [ HP.classes itemClasses
    , HE.onClick (HE.input_ Toggle)
    , HE.onMouseEnter (HE.input_ PresentActions)
    , HE.onMouseLeave (HE.input_ HideActions)
    , HE.onDoubleClick $ HE.input_ $ Open (itemResource item)
    , ARIA.label label
    ]
    [ HH.div
        [ HP.class_ B.row ]
        [ HH.div
            [ HP.classes [ B.colXs8, CSS.itemContent ] ]
            [ HH.a
                [ HE.onClick \_ →
                    HEH.preventDefault $>
                      Just (H.action (Open (itemResource item)))
                ]
                [ HH.i [ iconClasses item ] []
                , HH.text $ itemName state
                ]
            ]
        , HH.div
            [ HP.classes $ [ B.colXs4, CSS.itemToolbar ] ⊕ (guard selected $> CSS.selected) ]
            [ itemActions presentActions item ]
        ]
    ]
  where
  itemClasses ∷ Array HH.ClassName
  itemClasses =
    [ B.listGroupItem ]
    ⊕ (guard selected $> B.listGroupItemInfo)
    ⊕ (if itemIsHidden item && presentHiddenItem state then [ CSS.itemHidden ] else [ ])

  label ∷ String
  label | selected  = "Deselect " <> itemName state
  label | otherwise = "Select " <> itemName state

iconClasses ∷ forall i r. Item → HP.IProp (class ∷ HP.I | r) i
iconClasses item = HP.classes
  [ B.glyphicon
  , CSS.itemIcon
  , iconClass (itemResource item)
  ]
  where
  iconClass ∷ Resource → HH.ClassName
  iconClass (File _) = B.glyphiconFile
  iconClass (Workspace _) = B.glyphiconBook
  iconClass (Directory _) = B.glyphiconFolderOpen
  iconClass (Mount (Database _)) = B.glyphiconHdd
  iconClass (Mount (View _)) = B.glyphiconFile

itemActions ∷ Boolean → Item → HTML
itemActions presentActions item | not presentActions = HH.text ""
itemActions presentActions item | otherwise =
  HH.ul
    [ HP.classes [ B.listInline, B.pullRight ]
    , HCSS.style $ marginBottom (px zero)
    ]
    (conf ⊕ common ⊕ share)
  where
  r ∷ Resource
  r = itemResource item

  conf ∷ Array HTML
  conf = guard (isMount r) $>
    itemAction Configure "Configure" B.glyphiconWrench

  common ∷ Array HTML
  common =
    [
      itemAction Move "Move / rename" B.glyphiconMove
    , itemAction Download "Download" B.glyphiconCloudDownload
    , itemAction Remove "Remove" B.glyphiconTrash
    ]

  share ∷ Array HTML
  share = guard (isFile r || isWorkspace r || isViewMount r) $>
    itemAction Share "Share" B.glyphiconShare

  itemAction ∷ (Resource → H.Action Query) → String → HH.ClassName → HTML
  itemAction act label cls =
    HH.li_
      [ HH.button
          [ HE.onClick $ HE.input_ (act (itemResource item))
          , HP.title label
          , ARIA.label label
          , HP.class_ CSS.fileAction
          ]
          [ HH.i [ HP.classes [ B.glyphicon, cls ] ] [] ]
      ]


code cleanup

code cleanup

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    stateful,
    variant,
    sized,
    resize,
    choose,
    chooseInt,
    oneOf,
    frequency,
    listOf,
    listOf1,
    vectorOf,
    elements,
    runGen,
    evalGen,
    perturbGen,
    uniform,
    showSample,
    showSample'
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Debug.Trace
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.floor <$> choose (M.ceil a) (M.floor b + 0.999999999)

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value

sample :: forall r a. Size -> Gen a -> [a]
sample sz g = evalGen (vectorOf sz g) { newSeed: 0, size: sz }

showSample' :: forall r a. (Show a) => Size -> Gen a -> Eff (trace :: Trace | r) Unit
showSample' n g = print $ sample n g

showSample :: forall r a. (Show a) => Gen a -> Eff (trace :: Trace | r) Unit
showSample = showSample' 10

--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    stateful,
    variant,
    sized,
    resize,
    choose,
    chooseInt,
    oneOf,
    frequency,
    listOf,
    listOf1,
    vectorOf,
    elements,
    runGen,
    evalGen,
    perturbGen,
    uniform,
    showSample,
    showSample'
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Debug.Trace
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.floor <$> choose (M.ceil a) (M.floor b + 0.999999999)

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value

sample :: forall r a. Size -> Gen a -> [a]
sample sz g = evalGen (vectorOf sz g) { newSeed: 0, size: sz }

showSample' :: forall r a. (Show a) => Size -> Gen a -> Eff (trace :: Trace | r) Unit
showSample' n g = print $ sample n g

showSample :: forall r a. (Show a) => Gen a -> Eff (trace :: Trace | r) Unit
showSample g = showSample' 10 g

--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen


Refactorings

Refactorings

module Starter.Kit.Example where

import Data.Char
import Data.Array
import Data.Maybe
import Data.Tuple

newtype Parser a = P ([Char] -> [Tuple a [Char]])

parse :: forall a. Parser a -> [Char] -> [Tuple a [Char]]
parse (P p) s = p s

fail :: forall a. Parser a
fail = P (\s -> [])

item :: Parser Char
item = P (\s -> case s of
                     [] -> []
                     x:xs -> [Tuple x xs])

instance functorParsers :: Functor Parser where
--(<$>) :: forall a b. (a -> b) -> f a -> f b
  (<$>) f m =  P (\s -> case (parse m s) of
  	                      [] -> []
  	                      [Tuple v s'] -> [Tuple (f v)  s'])

instance applyParsers :: Apply Parser where
--(<*>) :: forall a b. f (a -> b) -> f a -> f b
  (<*>) mf m = P(\s -> case (parse mf s) of
  	                      [] -> []
  	                      [Tuple f s'] -> case (parse m s') of
  	                                        [] -> []
  	                                        [Tuple v s''] -> [Tuple (f v) s''])

instance applicativeParsers :: Applicative Parser where
--pure :: forall a. a -> f a
  pure x = P (\s -> [Tuple x s])

instance bindParsers :: Bind Parser where
  (>>=) m f = P(\s -> case (parse m s) of
  	                    [] -> []
  	                    [Tuple v s'] -> parse (f v) s')

instance monadParsers :: Monad Parser

sat :: (Char -> Boolean) -> Parser Char
sat p = do x <- item
           if (p x) then return x else fail


comment out scaling callbacks

comment out scaling callbacks

to track down the cause of the compile error on the new polymorphic AttrFn

module Main where

import D3.Selection (attr, append, enter, dataBind, selectAll, text, getAttr, d3Select)
import D3.Collections (D3Collection(..), d3Map)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import D3.Base (PolyValue(Value), AttrSetter(SetAttr, AttrFn), DataBind(Data), D3, (..), (...))
import D3.Scale (ScaleType(..), scale, bandwidth, rangeRound, d3Scale, padding, domain)
import Data.Maybe (Maybe(Just))
import Prelude (Unit, unit, pure, bind, show, (-), (<>))

-- define a margin, look to purescript-css for more sophisticated definition
margin :: { top::Number, right::Number, bottom::Number, left::Number }
margin = { top: 20.0, right: 20.0, bottom: 30.0, left: 40.0}

frequencies :: Array { letter :: Char, frequency :: Number }
frequencies = [
    { letter: 'A',	frequency: 0.08167 }
  , { letter: 'B',	frequency: 0.01492 }
  , { letter: 'C',	frequency: 0.02782 }
  , { letter: 'D',	frequency: 0.04253 }
  , { letter: 'E',	frequency: 0.12702 }
  , { letter: 'F',	frequency: 0.02288 }
  , { letter: 'G',	frequency: 0.02015 }
  , { letter: 'H',	frequency: 0.06094 }
  , { letter: 'I',	frequency: 0.06966 }
  , { letter: 'J',	frequency: 0.00153 }
  , { letter: 'K',	frequency: 0.00772 }
  , { letter: 'L',	frequency: 0.04025 }
  , { letter: 'M',	frequency: 0.02406 }
  , { letter: 'N',	frequency: 0.06749 }
  , { letter: 'O',	frequency: 0.07507 }
  , { letter: 'P',	frequency: 0.01929 }
  , { letter: 'Q',	frequency: 0.00095 }
  , { letter: 'R',	frequency: 0.05987 }
  , { letter: 'S',	frequency: 0.06327 }
  , { letter: 'T',	frequency: 0.09056 }
  , { letter: 'U',	frequency: 0.02758 }
  , { letter: 'V',	frequency: 0.00978 }
  , { letter: 'W',	frequency: 0.02360 }
  , { letter: 'X',	frequency: 0.00150 }
  , { letter: 'Y',	frequency: 0.01974 }
  , { letter: 'Z',	frequency: 0.00074 }
]

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  svg <- d3Select ".svg"

  w <- svg ... getAttr "width"
  h <- svg ... getAttr "height"
  let width =  w - margin.left - margin.right
  let height = h - margin.top - margin.bottom

  asMap <- (d3Map frequencies (Just (\d -> d.letter)))

  x <- d3Scale Band
        .. rangeRound 0.0 width
        .. padding 0.1
        .. domain (D3MapT asMap)
  y <- d3Scale Linear
        .. rangeRound height 0.0
        .. domain (D3StartEnd 0.0 0.12702) -- implement max lookup later TODO

  g <-  svg ... append "g"
    ..  attr "transform"  (SetAttr ("translate(" <> show margin.left <> "," <> show margin.top <> ")"))

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--x")
    ..  attr "transform"  (SetAttr ("translate(0," <> show height <> ")"))
    -- ..  call d3AxisBottom x

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--y")
    -- ..  call d3AxisLeft y .. ticks 10 '%'
    .. append "text"
    .. attr "transform"   (SetAttr "rotate(-90)")
    .. attr "y"           (SetAttr 6.0)
    .. attr "dy"          (SetAttr "0.71em")
    .. attr "text-anchor" (SetAttr "end")
    .. text (Value "Frequency")

  g ... selectAll (".bar")
      .. dataBind (Data frequencies)
    .. enter .. append "rect"
      .. attr "class"  (SetAttr "bar")
      .. attr "x"      (AttrFn (\d i nodes el -> 10.0))
      -- .. attr "x"      (AttrFn (\d i nodes el -> do scaled <- scale d.letter x
      --                                               pure scaled
      --                          ))
      -- .. attr "y"      (AttrFn (\d i nodes el -> do scaled <- scale d.frequency y
      --                                               pure scaled
      --                          ))
      -- .. attr "width"  (SetAttr (bandwidth x))
      -- .. attr "height" (AttrFn (\d i nodes el -> do
      --                                               scaled <- scale d.frequency y
      --                                               pure (height - scaled)
                              --  ))

  pure unit

module Main where

import D3.Selection (attr, append, enter, dataBind, selectAll, text, getAttr, d3Select)
import D3.Collections (D3Collection(..), d3Map)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import D3.Base (PolyValue(Value), AttrSetter(SetAttr, AttrFn), DataBind(Data), D3, (..), (...))
import D3.Scale (ScaleType(..), scale, bandwidth, rangeRound, d3Scale, padding, domain)
import Data.Maybe (Maybe(Just))
import Prelude (Unit, unit, pure, bind, show, (-), (<>))

-- define a margin, look to purescript-css for more sophisticated definition
margin :: { top::Number, right::Number, bottom::Number, left::Number }
margin = { top: 20.0, right: 20.0, bottom: 30.0, left: 40.0}

frequencies :: Array { letter :: Char, frequency :: Number }
frequencies = [
    { letter: 'A',	frequency: 0.08167 }
  , { letter: 'B',	frequency: 0.01492 }
  , { letter: 'C',	frequency: 0.02782 }
  , { letter: 'D',	frequency: 0.04253 }
  , { letter: 'E',	frequency: 0.12702 }
  , { letter: 'F',	frequency: 0.02288 }
  , { letter: 'G',	frequency: 0.02015 }
  , { letter: 'H',	frequency: 0.06094 }
  , { letter: 'I',	frequency: 0.06966 }
  , { letter: 'J',	frequency: 0.00153 }
  , { letter: 'K',	frequency: 0.00772 }
  , { letter: 'L',	frequency: 0.04025 }
  , { letter: 'M',	frequency: 0.02406 }
  , { letter: 'N',	frequency: 0.06749 }
  , { letter: 'O',	frequency: 0.07507 }
  , { letter: 'P',	frequency: 0.01929 }
  , { letter: 'Q',	frequency: 0.00095 }
  , { letter: 'R',	frequency: 0.05987 }
  , { letter: 'S',	frequency: 0.06327 }
  , { letter: 'T',	frequency: 0.09056 }
  , { letter: 'U',	frequency: 0.02758 }
  , { letter: 'V',	frequency: 0.00978 }
  , { letter: 'W',	frequency: 0.02360 }
  , { letter: 'X',	frequency: 0.00150 }
  , { letter: 'Y',	frequency: 0.01974 }
  , { letter: 'Z',	frequency: 0.00074 }
]

main :: ∀ e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  svg <- d3Select ".svg"

  w <- svg ... getAttr "width"
  h <- svg ... getAttr "height"
  let width =  w - margin.left - margin.right
  let height = h - margin.top - margin.bottom

  asMap <- (d3Map frequencies (Just (\d -> d.letter)))

  x <- d3Scale Band
        .. rangeRound 0.0 width
        .. padding 0.1
        .. domain (D3MapT asMap)
  y <- d3Scale Linear
        .. rangeRound height 0.0
        .. domain (D3StartEnd 0.0 0.12702) -- implement max lookup later TODO

  g <-  svg ... append "g"
    ..  attr "transform"  (SetAttr ("translate(" <> show margin.left <> "," <> show margin.top <> ")"))

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--x")
    ..  attr "transform"  (SetAttr ("translate(0," <> show height <> ")"))
    -- ..  call d3AxisBottom x

  g ... append "g"
    ..  attr "class"      (SetAttr "axis axis--y")
    -- ..  call d3AxisLeft y .. ticks 10 '%'
    .. append "text"
    .. attr "transform"   (SetAttr "rotate(-90)")
    .. attr "y"           (SetAttr 6.0)
    .. attr "dy"          (SetAttr "0.71em")
    .. attr "text-anchor" (SetAttr "end")
    .. text (Value "Frequency")

  g ... selectAll (".bar")
      .. dataBind (Data frequencies)
    .. enter .. append "rect"
      .. attr "class"  (SetAttr "bar")
      .. attr "x"      (AttrFn (\d i nodes el -> do scaled <- scale d.letter x
                                                    pure scaled
                               ))
      .. attr "y"      (AttrFn (\d i nodes el -> do scaled <- scale d.frequency y
                                                    pure scaled
                               ))
      .. attr "width"  (SetAttr (bandwidth x))
      .. attr "height" (AttrFn (\d i nodes el -> do
                                                    scaled <- scale d.frequency y
                                                    pure (height - scaled)
                               ))

  pure unit


Consider missing desc arg as flag opt

Consider missing desc arg as flag opt

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===
-- |
-- | Thoughts:
-- |    * It appears there is never a reason to fail hard. It would be nice if
-- |      we could produce warnings, however -> Write monad?

module Language.Docopt.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Foldable (foldl)
import Control.MonadPlus (guard)
import Control.Plus (empty)
import Control.Alt ((<|>))
import Data.Monoid (mempty)
import Control.Monad.Error.Class (throwError)
import Data.Array as A
import Data.String as Str
import Data.StrMap as StrMap
import Data.StrMap (StrMap())

import Data.String.Ext ((^=))
import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Usage
import Language.Docopt.Parser.Desc (Desc(..))
import Language.Docopt.Value (Value(..))
import Language.Docopt.Option                as O
import Language.Docopt.Parser.Desc           as DE
import Language.Docopt.Parser.Usage          as U
import Language.Docopt.Parser.Usage.Argument as U
import Language.Docopt.Parser.Usage.Option   as UO

data Result = Consumed (List Argument) | Unconsumed (List Argument)

runResult :: Result -> List Argument
runResult (Consumed   xs) = xs
runResult (Unconsumed xs) = xs

solveBranch :: U.Branch                 -- ^ the usage branch
            -> List Desc                -- ^ the option descriptions
            -> Either SolveError Branch -- ^ the canonical usage branch
solveBranch as ds = Branch <$> go as
  where
    go :: U.Branch -> Either SolveError (List Argument)
    go Nil = return Nil
    go (Cons x Nil) = do runResult <$> do solveArgs x Nothing
    go (Cons x (Cons y xs)) = do
      m <- solveArgs x (Just y)
      case m of
        Unconsumed zs -> (zs ++) <$> go (y:xs)
        Consumed   zs -> (zs ++) <$> go xs

    -- | Solve two adjacent arguments.
    -- | Should the first argument be an option with an argument that
    -- | matches an adjacent command or positional, consume the adjacent
    -- | argument from the input (consume).
    solveArgs :: U.Argument
              -> Maybe U.Argument
              -> Either SolveError Result

    solveArgs (U.EOA) _ = Unconsumed <<< singleton <$> return (EOA)
    solveArgs (U.Stdin) _ = Unconsumed <<< singleton <$> return (Stdin)
    solveArgs (U.Command s) _ = Unconsumed <<< singleton <$> return (Command s)
    solveArgs (U.Positional s r) _ = Unconsumed <<< singleton <$> return (Positional s r)

    solveArgs (U.Group o bs r) _
      = Unconsumed <<< singleton <$> do
        flip (Group o) r <$> do
          flip solveBranch ds `traverse` bs

    -- | Resolve the refernce by expanding into real
    -- | options, as derived from the descriptions.
    -- |
    -- | XXX: Currently `r` is unused as all descriptions are in a flat list.
    -- |      once option descriptions are keyed, `r` can be used as the lookup
    -- |      into the map of `key => [Description]`
    solveArgs (U.Reference r) _ = do
      return $ Unconsumed (catMaybes $ convert <$> ds)

      where
        convert (DE.OptionDesc (DE.Option y)) =
          return $ Option
                 $ O.Option { flag:       DE.getFlag y.name
                            , name:       DE.getName y.name
                            , arg:        convertArg y.arg
                            , env:        y.env
                            , repeatable: false -- XXX: desc options must be
                                                --      able to indicate this!
                            }
          where
            convertArg (Just (DE.Argument arg))
              = return $ O.Argument arg

            -- If the option description species it takes no argument, it's a
            -- flag, and it's absence is counted as "false" via the default
            -- value.
            -- XXX: Note that this breaks, in some sense the idea that
            --      only named arguments take values. Does the argument
            --      structure need to change?
            convertArg _
              = return $ O.Argument { name: "" -- XXX: see comment above
                                    , default: pure $ BoolValue false
                                    }
        convert _ = Nothing

    solveArgs (U.Option (UO.LOpt o)) y = do

      -- XXX: Is `head` the right thing to do here? What if there are more
      -- matches? That would indicate ambigiutiy and needs to be treated,
      -- possibly with an error?
      let x = O.runOption $ flip maybe' id
                (\_ -> O.Option $ O.empty { name       = pure o.name
                                          , arg        = toArg o.arg
                                          , repeatable = o.repeatable
                                          })
                (head $ catMaybes $ coerce <$> ds)

      -- Validate the argument matches
      if (argMatches o.arg x.arg)
        then return unit
        else throwError $ DescriptionError $ ArgumentMismatchError {
                option: O.Option x
              , description: {
                  arg: x.arg <#> O.runArgument >>> _.name
                }
              }

      -- Look ahead if any of the following arguments should be consumed.
      -- Return either `Nothing` to signify that nothing should be consumed
      -- or a value signifieng that it should be consumed, and the
      -- `isRepeated` should be inherited.
      let mr = do
            guard (not o.repeatable)
            arg' <- O.runArgument <$> x.arg
            case y of
              Just (U.Positional n r) | n == arg'.name -> return r
              Just (U.Command n)      | n == arg'.name -> return false
              _                                        -> Nothing

      return $ (maybe Unconsumed (const Consumed) mr)
             $ singleton
             $ Option
             $ O.Option (x { repeatable = maybe (x.repeatable) id mr })

      where
        coerce :: Desc -> Maybe O.Option
        coerce (DE.OptionDesc (DE.Option x))
          = coerce' x
            where
              coerce' { name = DE.Long n' }
                | n' ^= o.name
                = return $ O.Option { name:       pure o.name
                                    , flag:       Nothing
                                    , arg:        resolveOptArg o.arg x.arg
                                    , env:        x.env
                                    , repeatable: o.repeatable
                                    }
              coerce' { name = DE.Full f' n' }
                | n' ^= o.name
                = return $ O.Option { name:       pure o.name
                                    , flag:       pure f'
                                    , arg:        resolveOptArg o.arg x.arg
                                    , env:        x.env
                                    , repeatable: o.repeatable
                                    }
        coerce _ = Nothing

    solveArgs (U.OptionStack (UO.SOpt o)) y = do

      -- Figure out trailing flag, in order to couple it with an adjacent
      -- option where needed.
      (Tuple xs x) <- do
          let fs = toList o.stack
              t  = case last fs of
                    Just f  -> Tuple (o.flag:(fromJust $ init fs)) f
                    Nothing -> Tuple Nil o.flag
          Tuple
            <$> (match false `traverse` (fst t))
            <*> (O.runOption <$> do match true (snd t))

      -- Validate the argument matches
      if (argMatches o.arg x.arg)
        then return unit
        else throwError $ DescriptionError $ ArgumentMismatchError {
                option: O.Option x
              , description: {
                  arg: x.arg <#> O.runArgument >>> _.name
                }
              }

      -- Look ahead if any of the following arguments should be consumed.
      -- Return either `Nothing` to signify that nothing should be consumed
      -- or a value signifieng that it should be consumed, and the
      -- `isRepeated` should be inherited.
      let mr = do
            guard (not x.repeatable)
            arg' <- O.runArgument <$> x.arg
            case y of
                Just (U.Positional n r) | n == arg'.name -> return r
                Just (U.Command n)      | n == arg'.name -> return false
                _                                        -> Nothing

      return $ (maybe Unconsumed (const Consumed) mr)
             $ (Option <$> xs)
                ++ (singleton $ Option $ O.Option $ x {
                      repeatable = maybe (x.repeatable) id mr
                    })

      where
        match :: Boolean -> Char -> Either SolveError O.Option
        match isTrailing f = return $
          flip maybe' id
                (\_ -> O.Option $ O.empty { flag = pure f
                                          , arg = toArg o.arg
                                          , repeatable = o.repeatable
                                          })
                (head $ catMaybes $ coerce f isTrailing <$> ds)

        coerce :: Char -> Boolean -> Desc -> Maybe O.Option
        coerce f isTrailing (DE.OptionDesc (DE.Option y))
          = coerce' y
            where
              coerce' { name = DE.Flag f' }
                | (f == f') && (isTrailing || isNothing y.arg)
                = return $ O.Option { flag:       pure f
                                    , name:       Nothing
                                    , arg:        resolveOptArg o.arg y.arg
                                    , env:        y.env
                                    , repeatable: o.repeatable
                                    }
              coerce' { name = DE.Full f' n' }
                | (f == f') && (isTrailing || isNothing y.arg)
                = return $ O.Option { flag:       pure f'
                                    , name:       pure n'
                                    , arg:        resolveOptArg o.arg y.arg
                                    , env:        y.env
                                    , repeatable: o.repeatable
                                  }
              coerce' _ = Nothing
        coerce _ _ _ = Nothing

    -- | Resolve an option's argument name against that given in the
    -- | description, returning the most complete argument known.
    resolveOptArg :: Maybe String
                  -> Maybe DE.Argument
                  -> Maybe O.Argument

    resolveOptArg (Just n) Nothing = do
      return $ O.Argument { name: n
                          , default: Nothing }
    resolveOptArg Nothing (Just (DE.Argument a))
      = return $ O.Argument { name: a.name
                            , default: a.default
                            }
    -- XXX: Do we need to guard that `an == a.name` here?
    resolveOptArg (Just an) (Just (DE.Argument a))
      = return $ O.Argument { name: a.name
                            , default: a.default
                            }
    resolveOptArg _ _ = Nothing

    toArg:: Maybe String -> Maybe O.Argument
    toArg a = do
      an <- a
      return $ O.Argument { name: an
                          , default: Nothing }

    argMatches :: Maybe String
               -> Maybe O.Argument
               -> Boolean
    argMatches a a'
      =  (isNothing a)
      || (isNothing a && isNothing a')
      || (maybe false id do
          an <- a
          (O.Argument { name: an' }) <- a'
          return (an ^= an')
        )

solveUsage :: U.Usage -> List Desc -> Either SolveError Usage
solveUsage (U.Usage _ bs) ds = Usage <$> do traverse (flip solveBranch ds) bs

solve :: (List U.Usage)
      -> (List Desc)
      -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===
-- |
-- | Thoughts:
-- |    * It appears there is never a reason to fail hard. It would be nice if
-- |      we could produce warnings, however -> Write monad?

module Language.Docopt.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Foldable (foldl)
import Control.MonadPlus (guard)
import Control.Plus (empty)
import Control.Alt ((<|>))
import Data.Monoid (mempty)
import Control.Monad.Error.Class (throwError)
import Data.Array as A
import Data.String as Str
import Data.StrMap as StrMap
import Data.StrMap (StrMap())

import Data.String.Ext ((^=))
import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Usage
import Language.Docopt.Parser.Desc (Desc(..))
import Language.Docopt.Value (Value(..))
import Language.Docopt.Option                as O
import Language.Docopt.Parser.Desc           as DE
import Language.Docopt.Parser.Usage          as U
import Language.Docopt.Parser.Usage.Argument as U
import Language.Docopt.Parser.Usage.Option   as UO

data Result = Consumed (List Argument) | Unconsumed (List Argument)

runResult :: Result -> List Argument
runResult (Consumed   xs) = xs
runResult (Unconsumed xs) = xs

solveBranch :: U.Branch                 -- ^ the usage branch
            -> List Desc                -- ^ the option descriptions
            -> Either SolveError Branch -- ^ the canonical usage branch
solveBranch as ds = Branch <$> go as
  where
    go :: U.Branch -> Either SolveError (List Argument)
    go Nil = return Nil
    go (Cons x Nil) = do runResult <$> do solveArgs x Nothing
    go (Cons x (Cons y xs)) = do
      m <- solveArgs x (Just y)
      case m of
        Unconsumed zs -> (zs ++) <$> go (y:xs)
        Consumed   zs -> (zs ++) <$> go xs

    -- | Solve two adjacent arguments.
    -- | Should the first argument be an option with an argument that
    -- | matches an adjacent command or positional, consume the adjacent
    -- | argument from the input (consume).
    solveArgs :: U.Argument
              -> Maybe U.Argument
              -> Either SolveError Result

    solveArgs (U.EOA) _ = Unconsumed <<< singleton <$> return (EOA)
    solveArgs (U.Stdin) _ = Unconsumed <<< singleton <$> return (Stdin)
    solveArgs (U.Command s) _ = Unconsumed <<< singleton <$> return (Command s)
    solveArgs (U.Positional s r) _ = Unconsumed <<< singleton <$> return (Positional s r)

    solveArgs (U.Group o bs r) _
      = Unconsumed <<< singleton <$> do
        flip (Group o) r <$> do
          flip solveBranch ds `traverse` bs

    -- | Resolve the refernce by expanding into real
    -- | options, as derived from the descriptions.
    -- |
    -- | XXX: Currently `r` is unused as all descriptions are in a flat list.
    -- |      once option descriptions are keyed, `r` can be used as the lookup
    -- |      into the map of `key => [Description]`
    solveArgs (U.Reference r) _ = do
      return $ Unconsumed (catMaybes $ convert <$> ds)

      where
        convert (DE.OptionDesc (DE.Option y)) =
          return $ Option
                 $ O.Option { flag: DE.getFlag y.name
                            , name: DE.getName y.name
                            , arg:  do
                                -- XXX: Use alt <|> here, in case the option
                                --      is a flag (takes no argument) and
                                --      overwrite it to take an argument of
                                --      with a default BoolValue of "false".
                                --      How to name the anonymous argument?
                                --      This may require a change to the option
                                --      structure: move "name" and "default"
                                --      out of the "Argument" structure into
                                --      the "Option" structure?
                                a <- DE.runArgument <$> y.arg
                                return $ O.Argument a
                            , env: y.env
                            , repeatable: false -- XXX: desc options must be
                                                --      able to indicate this!
                            }
        convert _ = Nothing

    solveArgs (U.Option (UO.LOpt o)) y = do

      -- XXX: Is `head` the right thing to do here? What if there are more
      -- matches? That would indicate ambigiutiy and needs to be treated,
      -- possibly with an error?
      let x = O.runOption $ flip maybe' id
                (\_ -> O.Option $ O.empty { name       = pure o.name
                                          , arg        = toArg o.arg
                                          , repeatable = o.repeatable
                                          })
                (head $ catMaybes $ coerce <$> ds)

      -- Validate the argument matches
      if (argMatches o.arg x.arg)
        then return unit
        else throwError $ DescriptionError $ ArgumentMismatchError {
                option: O.Option x
              , description: {
                  arg: x.arg <#> O.runArgument >>> _.name
                }
              }

      -- Look ahead if any of the following arguments should be consumed.
      -- Return either `Nothing` to signify that nothing should be consumed
      -- or a value signifieng that it should be consumed, and the
      -- `isRepeated` should be inherited.
      let mr = do
            guard (not o.repeatable)
            arg' <- O.runArgument <$> x.arg
            case y of
              Just (U.Positional n r) | n == arg'.name -> return r
              Just (U.Command n)      | n == arg'.name -> return false
              _                                        -> Nothing

      return $ (maybe Unconsumed (const Consumed) mr)
             $ singleton
             $ Option
             $ O.Option (x { repeatable = maybe (x.repeatable) id mr })

      where
        coerce :: Desc -> Maybe O.Option
        coerce (DE.OptionDesc (DE.Option x))
          = coerce' x
            where
              coerce' { name = DE.Long n' }
                | n' ^= o.name
                = return $ O.Option { name:       pure o.name
                                    , flag:       Nothing
                                    , arg:        resolveOptArg o.arg x.arg
                                    , env:        x.env
                                    , repeatable: o.repeatable
                                    }
              coerce' { name = DE.Full f' n' }
                | n' ^= o.name
                = return $ O.Option { name:       pure o.name
                                    , flag:       pure f'
                                    , arg:        resolveOptArg o.arg x.arg
                                    , env:        x.env
                                    , repeatable: o.repeatable
                                    }
        coerce _ = Nothing

    solveArgs (U.OptionStack (UO.SOpt o)) y = do

      -- Figure out trailing flag, in order to couple it with an adjacent
      -- option where needed.
      (Tuple xs x) <- do
          let fs = toList o.stack
              t  = case last fs of
                    Just f  -> Tuple (o.flag:(fromJust $ init fs)) f
                    Nothing -> Tuple Nil o.flag
          Tuple
            <$> (match false `traverse` (fst t))
            <*> (O.runOption <$> do match true (snd t))

      -- Validate the argument matches
      if (argMatches o.arg x.arg)
        then return unit
        else throwError $ DescriptionError $ ArgumentMismatchError {
                option: O.Option x
              , description: {
                  arg: x.arg <#> O.runArgument >>> _.name
                }
              }

      -- Look ahead if any of the following arguments should be consumed.
      -- Return either `Nothing` to signify that nothing should be consumed
      -- or a value signifieng that it should be consumed, and the
      -- `isRepeated` should be inherited.
      let mr = do
            guard (not x.repeatable)
            arg' <- O.runArgument <$> x.arg
            case y of
                Just (U.Positional n r) | n == arg'.name -> return r
                Just (U.Command n)      | n == arg'.name -> return false
                _                                        -> Nothing

      return $ (maybe Unconsumed (const Consumed) mr)
             $ (Option <$> xs)
                ++ (singleton $ Option $ O.Option $ x {
                      repeatable = maybe (x.repeatable) id mr
                    })

      where
        match :: Boolean -> Char -> Either SolveError O.Option
        match isTrailing f = return $
          flip maybe' id
                (\_ -> O.Option $ O.empty { flag = pure f
                                          , arg = toArg o.arg
                                          , repeatable = o.repeatable
                                          })
                (head $ catMaybes $ coerce f isTrailing <$> ds)

        coerce :: Char -> Boolean -> Desc -> Maybe O.Option
        coerce f isTrailing (DE.OptionDesc (DE.Option y))
          = coerce' y
            where
              coerce' { name = DE.Flag f' }
                | (f == f') && (isTrailing || isNothing y.arg)
                = return $ O.Option { flag:       pure f
                                    , name:       Nothing
                                    , arg:        resolveOptArg o.arg y.arg
                                    , env:        y.env
                                    , repeatable: o.repeatable
                                    }
              coerce' { name = DE.Full f' n' }
                | (f == f') && (isTrailing || isNothing y.arg)
                = return $ O.Option { flag:       pure f'
                                    , name:       pure n'
                                    , arg:        resolveOptArg o.arg y.arg
                                    , env:        y.env
                                    , repeatable: o.repeatable
                                  }
              coerce' _ = Nothing
        coerce _ _ _ = Nothing

    -- | Resolve an option's argument name against that given in the
    -- | description, returning the most complete argument known.
    resolveOptArg :: Maybe String
                  -> Maybe DE.Argument
                  -> Maybe O.Argument

    resolveOptArg (Just n) Nothing = do
      return $ O.Argument { name: n
                          , default: Nothing }
    resolveOptArg Nothing (Just (DE.Argument a))
      = return $ O.Argument { name: a.name
                            , default: a.default
                            }
    -- XXX: Do we need to guard that `an == a.name` here?
    resolveOptArg (Just an) (Just (DE.Argument a))
      = return $ O.Argument { name: a.name
                            , default: a.default
                            }
    resolveOptArg _ _ = Nothing

    toArg:: Maybe String -> Maybe O.Argument
    toArg a = do
      an <- a
      return $ O.Argument { name: an
                          , default: Nothing }

    argMatches :: Maybe String
               -> Maybe O.Argument
               -> Boolean
    argMatches a a'
      =  (isNothing a)
      || (isNothing a && isNothing a')
      || (maybe false id do
          an <- a
          (O.Argument { name: an' }) <- a'
          return (an ^= an')
        )

solveUsage :: U.Usage -> List Desc -> Either SolveError Usage
solveUsage (U.Usage _ bs) ds = Usage <$> do traverse (flip solveBranch ds) bs

solve :: (List U.Usage)
      -> (List Desc)
      -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us


Some initial EventSource comments

Some initial EventSource comments

module Halogen.Query.EventSource where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff, attempt, launchAff_)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Free.Trans as FT
import Control.Monad.Trans.Class (lift)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Monoid (class Monoid)
import Data.Profunctor (dimap)

-- | An event source definition - an effect in `m` that when run returns a
-- | producer coroutine that emits queries of type `f`, and runs in the effect
-- | monad `m`.
-- |
-- | It's generally unnecessary to build values of this type directly with this
-- | constructor, the `affEventSource` and `effEventSource` cover the most
-- | event source constructions.
newtype EventSource m f = EventSource (m { producer :: CR.Producer (f Unit) m Unit, finalizer :: Finalizer m })

-- | Constructs an event source from a setup function that operates in `Aff`.
-- |
-- | - The `Emitter` that the passed function receives is used to `emit` queries
-- |   that will be received by the current component, or can be `close`d to
-- |   shut down the event source and remove the subscription.
-- | - The `Finalizer` that the passed function produces is there to allow for
-- |   some clean-up action to be taken when the event source is unsubscribed
-- |   from. This also runs if the `Emitter` is `close`d.
affEventSource
  :: forall m f eff
   . MonadAff (avar :: AVAR | eff) m
  => (Emitter (Aff (avar :: AVAR | eff)) f -> Aff (avar :: AVAR | eff) (Finalizer (Aff (avar :: AVAR | eff))))
  -> EventSource m f
affEventSource recv = EventSource $ liftAff do
  inputVar <- AV.makeEmptyVar
  finalizeVar <- AV.makeEmptyVar
  let
    producer = do
      lift $ liftAff $ flip AV.putVar finalizeVar =<< recv (Emitter (flip AV.putVar inputVar))
      CR.producer $ liftAff $ AV.takeVar inputVar
    finalizer = Finalizer do
      liftAff (attempt (AV.takeVar finalizeVar)) >>= case _ of
        Left _ -> pure unit
        Right finalizer -> liftAff do
          AV.killVar (Exn.error "finalized") finalizeVar
          finalize finalizer
  pure { producer, finalizer }

-- | Constructs an event source from a setup function that operates in `Eff`.
-- |
-- | - The `Emitter` that the passed function receives is used to `emit` queries
-- |   that will be received by the current component, or can be `close`d to
-- |   shut down the event source and remove the subscription.
-- | - The `Finalizer` that the passed function produces is there to allow for
-- |   some clean-up action to be taken when the event source is unsubscribed
-- |   from. This also runs if the `Emitter` is `close`d.
effEventSource
  :: forall m f eff
   . MonadAff (avar :: AVAR | eff) m
  => (Emitter (Eff (avar :: AVAR | eff)) f -> Eff (avar :: AVAR | eff) (Finalizer (Eff (avar :: AVAR | eff))))
  -> EventSource m f
effEventSource = affEventSource <<< dimap (hoistEmitter launchAff_) (liftEff <<< map (hoistFinalizer liftEff))

-- | Maps the query component of an event source.
interpret :: forall m f g. Functor m => (f ~> g) -> EventSource m f -> EventSource m g
interpret f (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.interpret (lmap f) e.producer, finalizer: e.finalizer })
      es

-- | Maps the effect monad component of an event source.
hoist :: forall m n f. Functor n => (m ~> n) -> EventSource m f -> EventSource n f
hoist nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.hoistFreeT nat e.producer, finalizer: hoistFinalizer nat e.finalizer })
      (nat es)

newtype Emitter m f = Emitter (Either (f Unit) Unit -> m Unit)

emit :: forall m f. Emitter m f -> (Unit -> f Unit) -> m Unit
emit (Emitter f) q = f (Left (q unit))

close :: forall m a. Emitter m a -> m Unit
close (Emitter f) = f (Right unit)

hoistEmitter :: forall m n f. (m Unit -> n Unit) -> Emitter m f -> Emitter n f
hoistEmitter nat (Emitter f) = Emitter (nat <<< f)

newtype Finalizer m = Finalizer (m Unit)

instance semigroupFinalizer :: Apply m => Semigroup (Finalizer m) where
  append (Finalizer a) (Finalizer b) = Finalizer (a *> b)

instance monoidFinalizer :: Applicative m => Monoid (Finalizer m) where
  mempty = Finalizer (pure unit)

finalize :: forall m. Finalizer m -> m Unit
finalize (Finalizer a) = a

hoistFinalizer :: forall m n. (m ~> n) -> Finalizer m -> Finalizer n
hoistFinalizer nat (Finalizer a) = Finalizer (nat a)

module Halogen.Query.EventSource where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff, attempt, launchAff_)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Free.Trans as FT
import Control.Monad.Trans.Class (lift)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Monoid (class Monoid)
import Data.Profunctor (dimap)

newtype EventSource m f = EventSource (m { producer :: CR.Producer (f Unit) m Unit, finalizer :: Finalizer m })

affEventSource
  :: forall m f eff
   . MonadAff (avar :: AVAR | eff) m
  => (Emitter (Aff (avar :: AVAR | eff)) f -> Aff (avar :: AVAR | eff) (Finalizer (Aff (avar :: AVAR | eff))))
  -> EventSource m f
affEventSource recv = EventSource $ liftAff do
  inputVar <- AV.makeEmptyVar
  finalizeVar <- AV.makeEmptyVar
  let
    producer = do
      lift $ liftAff $ flip AV.putVar finalizeVar =<< recv (Emitter (flip AV.putVar inputVar))
      CR.producer $ liftAff $ AV.takeVar inputVar
    finalizer = Finalizer do
      liftAff (attempt (AV.takeVar finalizeVar)) >>= case _ of
        Left _ -> pure unit
        Right finalizer -> liftAff do
          AV.killVar (Exn.error "finalized") finalizeVar
          finalize finalizer
  pure { producer, finalizer }

effEventSource
  :: forall m f eff
   . MonadAff (avar :: AVAR | eff) m
  => (Emitter (Eff (avar :: AVAR | eff)) f -> Eff (avar :: AVAR | eff) (Finalizer (Eff (avar :: AVAR | eff))))
  -> EventSource m f
effEventSource = affEventSource <<< dimap (hoistEmitter launchAff_) (liftEff <<< map (hoistFinalizer liftEff))

interpret :: forall m f g. Functor m => (f ~> g) -> EventSource m f -> EventSource m g
interpret f (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.interpret (lmap f) e.producer, finalizer: e.finalizer })
      es

hoist :: forall m n f. Functor n => (m ~> n) -> EventSource m f -> EventSource n f
hoist nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.hoistFreeT nat e.producer, finalizer: hoistFinalizer nat e.finalizer })
      (nat es)

newtype Emitter m f = Emitter (Either (f Unit) Unit -> m Unit)

emit :: forall m f. Emitter m f -> (Unit -> f Unit) -> m Unit
emit (Emitter f) q = f (Left (q unit))

close :: forall m a. Emitter m a -> m Unit
close (Emitter f) = f (Right unit)

hoistEmitter :: forall m n f. (m Unit -> n Unit) -> Emitter m f -> Emitter n f
hoistEmitter nat (Emitter f) = Emitter (nat <<< f)

newtype Finalizer m = Finalizer (m Unit)

instance semigroupFinalizer :: Apply m => Semigroup (Finalizer m) where
  append (Finalizer a) (Finalizer b) = Finalizer (a *> b)

instance monoidFinalizer :: Applicative m => Monoid (Finalizer m) where
  mempty = Finalizer (pure unit)

finalize :: forall m. Finalizer m -> m Unit
finalize (Finalizer a) = a

hoistFinalizer :: forall m n. (m ~> n) -> Finalizer m -> Finalizer n
hoistFinalizer nat (Finalizer a) = Finalizer (nat a)


C# option to use List instead of Array

C# option to use List instead of Array

module Language.CSharp
    ( renderer
    ) where

import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Options (booleanOption, Option)

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

serializersOption :: Option Boolean
serializersOption = booleanOption "serializers" "Generate serializers" true

listOption :: Option Boolean
listOption = booleanOption "use-list" "Use List<T> instead of T[]" false

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [serializersOption.specification, listOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

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

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

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

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        useList <- getOptionValue listOption
        if useList
            then
                pure $ "List<" <> rendered <> ">"
            else
                pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
    line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
    forEachTopLevel_ \topLevelName topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelName
        line "//"
        line $ "//    var data = " <> module_ <> ".Convert." <> prefix <> "FromJson(jsonString);"
    line "//"
    line $ "namespace " <> module_
    line "{"
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;
"""
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        blank
        renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers doc = do
    serializers <- getOptionValue serializersOption
    when serializers doc

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

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Convert" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            whenSerializers do
                line
                    $ "public static string ToJson("
                    <> topLevelTypeRendered
                    <> " o) => JsonConvert.SerializeObject(o, Settings);"

        blank
        line "// JsonConverter stuff"

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

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"

        blank
        line "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Convert() },"
        line "};"
    line "}"

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

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

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

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

renderPrimitiveDeserializer :: List String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveDeserializer tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericDeserializer predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "public struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        whenSerializers do
            blank
            line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
            line "{"
            indent do
                forUnion_ nonNullUnion \field -> do
                    fieldName <- unionFieldName field
                    line $ "if (" <> fieldName <> " != null) {"
                    indent do
                        line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                        line "return;"
                    line "}"
                if hasNull
                    then
                        line "writer.WriteNull();"
                    else
                        line "throw new Exception(\"Union must not be null\");"
            line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    line $ "public class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            unless isLast blank
    line "}"

module Language.CSharp
    ( renderer
    ) where

import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Options (booleanOption, Option)

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

serializersOption :: Option Boolean
serializersOption = booleanOption "serializers" "Generate serializers?" true

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [serializersOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

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

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

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

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
    line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
    forEachTopLevel_ \topLevelName topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelName
        line "//"
        line $ "//    var data = " <> module_ <> ".Convert." <> prefix <> "FromJson(jsonString);"
    line "//"
    line $ "namespace " <> module_
    line "{"
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;
"""
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        blank
        renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers doc = do
    serializers <- getOptionValue serializersOption
    when serializers doc

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

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Convert" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            whenSerializers do
                line
                    $ "public static string ToJson("
                    <> topLevelTypeRendered
                    <> " o) => JsonConvert.SerializeObject(o, Settings);"

        blank
        line "// JsonConverter stuff"

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

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"

        blank
        line "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Convert() },"
        line "};"
    line "}"

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

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

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

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

renderPrimitiveDeserializer :: List String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveDeserializer tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericDeserializer predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "public struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        whenSerializers do
            blank
            line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
            line "{"
            indent do
                forUnion_ nonNullUnion \field -> do
                    fieldName <- unionFieldName field
                    line $ "if (" <> fieldName <> " != null) {"
                    indent do
                        line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                        line "return;"
                    line "}"
                if hasNull
                    then
                        line "writer.WriteNull();"
                    else
                        line "throw new Exception(\"Union must not be null\");"
            line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    line $ "public class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            unless isLast blank
    line "}"


added get/set rotation

added get/set rotation

module Graphics.Three.Object3D where

import Graphics.Three.Math.Vector
import Graphics.Three.Types
import Graphics.Three.Util
import Control.Monad.Eff

import qualified Graphics.Three.Camera as C
import qualified Graphics.Three.Material as M
import qualified Graphics.Three.Geometry as G

foreign import data Mesh :: *
foreign import data Line :: *

class Object3D a where
    getPosition      :: a -> ThreeEff Vector3
    setPosition      :: a -> Number -> Number -> Number -> ThreeEff Unit
    getRotationEuler :: a -> Number -> Number -> Number -> ThreeEff Euler
    setRotationEuler :: a -> Number -> Number -> Number -> ThreeEff Unit
    rotateIncrement  :: a -> Number -> Number -> Number -> ThreeEff Unit

instance object3DMesh :: Object3D Mesh where
    getPosition      = unsafeGetPosition
    setPosition      = unsafeSetPosition
    getRotationEuler = unsafeGetRotationEuler
    setRotationEuler = unsafeSetRotationEuler
    rotateIncrement  = unsafeRotateIncrement

instance object3DLine :: Object3D Line where
    getPosition      = unsafeGetPosition
    setPosition      = unsafeSetPosition
    getRotationEuler = unsafeGetRotationEuler
    setRotationEuler = unsafeSetRotationEuler
    rotateIncrement  = unsafeRotateIncrement

instance object3DCamera :: Object3D C.Camera where
    getPosition      = unsafeGetPosition
    setPosition      = unsafeSetPosition
    getRotationEuler = unsafeGetRotationEuler
    setRotationEuler = unsafeSetRotationEuler
    rotateIncrement  = unsafeRotateIncrement

class Renderable a where
    getGeometry :: a -> ThreeEff G.Geometry
    getMaterial :: forall b. (M.Material b) => a -> ThreeEff b

instance renderableMesh :: Renderable Mesh where
    getGeometry     = unsafeGetGeometry
    getMaterial     = unsafeGetMaterial

instance renderableLine :: Renderable Line where
    getGeometry     = unsafeGetGeometry
    getMaterial     = unsafeGetMaterial

data LineType = LineStrip | LinePieces

instance showLineType :: Show LineType where
    show LineStrip  = "LineStrip"
    show LinePieces = "LinePieces"

createMesh :: forall a. (M.Material a) => G.Geometry -> a -> ThreeEff Mesh
createMesh = ffi ["geometry", "material", ""] "new THREE.Mesh(geometry, material)"

createLine :: forall a. (M.Material a) => G.Geometry -> a -> LineType -> ThreeEff Line
createLine g m t = create g m $ show t
    where
        create = ffi ["geometry", "material", "lineType", ""] "new THREE.Line(geometry, material)"

unsafeGetPosition      = ffi ["object", ""] "object.position"
unsafeSetPosition      = fpi ["object", "x", "y", "z", ""] "object.position.set(x, y, z)" --TODO change to vector?
unsafeGetRotationEuler = ffi ["object", ""] "object.rotation"
unsafeSetRotationEuler = fpi ["object", "x", "y", "z", ""] "object.rotation.set(x, y, z)" --TODO change to euler? Add order
unsafeGetGeometry      = ffi ["object", ""] "object.geometry"
unsafeGetMaterial      = ffi ["object", ""] "object.material"
unsafeRotateIncrement  = fpi ["object", "x", "y", "z", ""]
    "object.rotation.x += x; object.rotation.y += y; object.rotation.z += z;"

module Graphics.Three.Object3D where

import Graphics.Three.Math.Vector
import Graphics.Three.Types
import Graphics.Three.Util
import Control.Monad.Eff

import qualified Graphics.Three.Camera as C
import qualified Graphics.Three.Material as M
import qualified Graphics.Three.Geometry as G

foreign import data Mesh :: *
foreign import data Line :: *

class Object3D a where
    getPosition :: a -> ThreeEff Vector3
    setPosition :: a -> Number -> Number -> Number -> ThreeEff Unit
    {--getRotationEuler :: forall eff. a -> Number -> Number -> Number -> Eff (three :: Three | eff) --}
    {--setRotationEuler :: forall eff. a -> Number -> Number -> Number -> Eff (three :: Three | eff) Unit--}
    rotateIncrement :: a -> Number -> Number -> Number -> ThreeEff Unit

instance object3DMesh :: Object3D Mesh where
    getPosition     = unsafeGetPosition
    setPosition     = unsafeSetPosition
    rotateIncrement = unsafeRotateIncrement

instance object3DLine :: Object3D Line where
    getPosition     = unsafeGetPosition
    setPosition     = unsafeSetPosition
    rotateIncrement = unsafeRotateIncrement

instance object3DCamera :: Object3D C.Camera where
    getPosition     = unsafeGetPosition
    setPosition     = unsafeSetPosition
    rotateIncrement = unsafeRotateIncrement

class Renderable a where
    getGeometry :: a -> ThreeEff G.Geometry
    getMaterial :: forall b. (M.Material b) => a -> ThreeEff b

instance renderableMesh :: Renderable Mesh where
    getGeometry     = unsafeGetGeometry
    getMaterial     = unsafeGetMaterial

instance renderableLine :: Renderable Line where
    getGeometry     = unsafeGetGeometry
    getMaterial     = unsafeGetMaterial

data LineType = LineStrip | LinePieces

instance showLineType :: Show LineType where
    show LineStrip  = "LineStrip"
    show LinePieces = "LinePieces"

createMesh :: forall a. (M.Material a) => G.Geometry -> a -> ThreeEff Mesh
createMesh = ffi ["geometry", "material", ""] "new THREE.Mesh(geometry, material)"

createLine :: forall a. (M.Material a) => G.Geometry -> a -> LineType -> ThreeEff Line
createLine g m t = create g m $ show t
    where
        create = ffi ["geometry", "material", "lineType", ""] "new THREE.Line(geometry, material)"

unsafeGetPosition = ffi ["object", ""] "object.position"
unsafeSetPosition = fpi ["object", "x", "y", "z", ""] "object.position.set(x, y, z)"
unsafeGetGeometry = ffi ["object", ""] "object.geometry"
unsafeGetMaterial = ffi ["object", ""] "object.material"
unsafeRotateIncrement = fpi ["object", "x", "y", "z", ""]
    "object.rotation.x += x; object.rotation.y += y; object.rotation.z += z;"


Delete Solver.purs

Delete Solver.purs