Some tidying

Some tidying

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Component
  ( component
  , module SlamData.Workspace.Component.Query
  ) where

import SlamData.Prelude

import Control.Monad.Aff.AVar (makeVar, peekVar, takeVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Ref (readRef)
import Control.UI.Browser as Browser

import Data.List as List
import Data.Time.Duration (Milliseconds(..))

import DOM.Classy.Event (currentTarget, target) as DOM
import DOM.Classy.Node (toNode) as DOM

import Halogen as H

import Halogen.Component.Utils (busEventSource)
import Halogen.Component.Utils.Throttled (throttledEventSource_)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Guide.StepByStep.Component as Guide
import SlamData.Header.Component as Header
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar as Quasar
import SlamData.Quasar.Auth.Authentication as Authentication
import SlamData.Quasar.Error as QE
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Component.ChildSlot (ChildQuery, ChildSlot, cpDeck, cpGuide, cpHeader, cpNotify)
import SlamData.Workspace.Component.Query (Query(..))
import SlamData.Workspace.Component.State (State, initialState)
import SlamData.Workspace.Deck.Component as Deck
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide (GuideType(..))
import SlamData.Workspace.Guide as GuideData
import SlamData.Workspace.StateMode (StateMode(..))

import Utils (endSentence)
import Utils.DOM (onResize, nodeEq)
import Utils.LocalStorage as LocalStorage

type WorkspaceHTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type WorkspaceDSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ AT.AccessType → H.Component HH.HTML Query Unit Void Slam
component accessType =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render: render accessType
    , eval
    , initializer: Just $ Init unit
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ AT.AccessType → State → WorkspaceHTML
render accessType state =
  HH.div
    [ HP.classes
        $ (guard (AT.isReadOnly accessType) $> HH.ClassName "sd-published")
        ⊕ [ HH.ClassName "sd-workspace" ]
    , HE.onClick (HE.input DismissAll)
    ]
    [ header
    , deck
    , notifications
    , cardGuide
    , flipGuide
    ]
  where
  renderError err =
    HH.div
      [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
      [ HH.h1_
          [ HH.text "Couldn't load this SlamData workspace." ]
      , HH.p_
          [ HH.text $ endSentence $ QE.printQError err ]
      , if (QE.isUnauthorized err)
          then HH.p_ (renderSignInButton <$> state.providers)
          else HH.text ""
      ]

  renderSignInButton providerR =
    HH.button
      [ HE.onClick $ HE.input_ $ SignIn providerR
      , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
      , HP.type_ HP.ButtonButton
      ]
      [ HH.text $ "Sign in with " ⊕ providerR.displayName ]

  cardGuide =
    HH.div
      [ HP.classes (guard (state.guide /= Just CardGuide) $> B.hidden) ]
      [ HH.slot' cpGuide CardGuide Guide.component GuideData.cardGuideSteps (HE.input (HandleGuideMessage CardGuide)) ]

  flipGuide =
    HH.div
      [ HP.classes (guard (state.guide /= Just FlipGuide) $> B.hidden) ]
      [ HH.slot' cpGuide FlipGuide Guide.component GuideData.flipGuideSteps (HE.input (HandleGuideMessage FlipGuide)) ]

  notifications =
    HH.slot' cpNotify unit (NC.component (NC.renderModeFromAccessType accessType)) unit (const Nothing)

  header =
    if AT.isEditable accessType
      then HH.slot' cpHeader unit Header.component unit absurd
      else HH.text ""

  deck =
    case state.stateMode, state.cursor of
      Error error, _ → renderError error
      Loading, _ →
        HH.div
          [ HP.class_ $ HH.ClassName "sd-pending-overlay" ]
          [ HH.div_
              [ HH.i_ []
              , HH.span_ [ HH.text "Please wait while the workspace loads" ]
              ]
          ]
      _, List.Cons deckId cursor →
        HH.slot' cpDeck deckId (Deck.component { accessType, cursor, displayCursor: mempty, deckId }) unit (const Nothing)
      _, _ → HH.text "Error"

eval ∷ Query ~> WorkspaceDSL
eval = case _ of
  Init next → do
    { bus, accessType } ← H.lift Wiring.expose
    cardGuideStep ← initialCardGuideStep
    -- TODO:
    -- when (AT.isEditable accessType) do
    --   H.modify _ { cardGuideStep = cardGuideStep }
    H.subscribe $ busEventSource (H.request ∘ PresentStepByStepGuide) bus.stepByStep
    H.subscribe $ throttledEventSource_ (Milliseconds 100.0) onResize (H.request Resize)
    when (isNothing cardGuideStep) do
      void $ queryDeck $ H.action Deck.DismissedCardGuide
    pure next
  PresentStepByStepGuide guideType reply → do
    H.modify (_ { guide = Just guideType })
    pure $ reply H.Listening
  DismissAll ev next → do
    void $ H.query' cpHeader unit $ H.action Header.Dismiss
    eq ← H.liftEff $ nodeEq (DOM.toNode (DOM.target ev)) (DOM.toNode (DOM.currentTarget ev))
    when eq $ void $ queryDeck $ H.action Deck.Focus
    pure next
  Resize reply → do
    queryDeck (H.action Deck.UpdateCardSize)
    pure $ reply H.Listening
  New next → do
    st ← H.get
    when (List.null st.cursor) do
      runFreshWorkspace mempty
    pure next
  ExploreFile res next → do
    st ← H.get
    when (List.null st.cursor) do
      runFreshWorkspace
        [ CM.Open (R.File res)
        , CM.Table JT.emptyModel
        ]
    pure next
  Load cursor next → do
    st ← H.get
    case st.stateMode of
      Loading → do
        rootId ← H.lift P.loadWorkspace
        case rootId of
          Left err → do
            providers ←
              Quasar.retrieveAuthProviders <#> case _ of
                Right (Just providers) → providers
                _ → []
            H.modify _
              { stateMode = Error err
              , providers = providers
              }
            for_ (GE.fromQError err) GE.raiseGlobalError
          Right _ → loadCursor cursor
      _ → loadCursor cursor
    void $ queryDeck $ H.action Deck.Focus
    pure next
  SignIn providerR next → do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ takeVar idToken)
    pure next
  HandleGuideMessage slot Guide.Dismissed next → do
    case slot of
      CardGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedCardGuideKey true
        void $ queryDeck $ H.action Deck.DismissedCardGuide
      FlipGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedFlipGuideKey true
    H.modify (_ { guide = Nothing })
    pure next

  where
  loadCursor cursor = do
    cursor' ←
      if List.null cursor
        then do
          wiring ← H.lift Wiring.expose
          rootId ← H.liftAff $ peekVar wiring.eval.root
          pure (pure rootId)
        else
          hydrateCursor cursor
    H.modify _
      { stateMode = Ready
      , cursor = cursor'
      }

  hydrateCursor cursor = H.lift do
    wiring ← Wiring.expose
    ET.hydrateCursor
      <$> Cache.snapshot wiring.eval.decks
      <*> Cache.snapshot wiring.eval.cards
      <*> pure cursor

  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess $ auth.signIn
    H.liftEff Browser.reload

  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      for_ (Authentication.toNotificationOptions error) $
        flip Bus.write bus.notify
      Bus.write SignInFailure auth.signIn

runFreshWorkspace ∷ Array CM.AnyCardModel → WorkspaceDSL Unit
runFreshWorkspace cards = do
  { path, accessType, varMaps, bus } ← H.lift Wiring.expose
  deckId × cell ← H.lift $ P.freshWorkspace cards
  H.modify _
    { stateMode = Ready
    , cursor = pure deckId
    }
  void $ queryDeck $ H.action Deck.Focus
  let
    wait =
      H.liftAff (Bus.read cell.bus) >>= case _ of
        ED.Pending _ → wait
        ED.Complete _ _ → wait
        ED.CardComplete _ → wait
        ED.CardChange _ → H.gets _.cursor
        ED.NameChange _ → H.gets _.cursor
  cursor ← wait
  H.lift P.saveWorkspace
  urlVarMaps ← H.liftEff $ readRef varMaps
  navigate $ WorkspaceRoute path cursor (WA.Load accessType) urlVarMaps

-- TODO:
-- peek ∷ ∀ a. ChildQuery a → WorkspaceDSL Unit
-- peek = (const (pure unit)) ⨁ const (pure unit) ⨁ peekNotification
--   where
--   peekNotification ∷ NC.Query a → WorkspaceDSL Unit
--   peekNotification = case _ of
--     NC.Action N.ExpandGlobalMenu _ → do
--       queryHeaderGripper $ Gripper.StartDragging 0.0 unit
--       queryHeaderGripper $ Gripper.StopDragging unit
--     NC.Action (N.Fulfill var) _ →
--       void $ H.liftAff $ Aff.attempt $ putVar var unit
--     _ → pure unit

queryDeck ∷ ∀ a. Deck.Query a → WorkspaceDSL (Maybe a)
queryDeck q = do
  deckId ← H.gets (List.head ∘ _.cursor)
  join <$> for deckId \d → H.query' cpDeck d q

initialCardGuideStep ∷ WorkspaceDSL (Maybe Int)
initialCardGuideStep =
  H.lift
    $ either (const $ Just 0) (if _ then Nothing else Just 0)
    <$> LocalStorage.getLocalStorage GuideData.dismissedCardGuideKey

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Component
  ( component
  , module SlamData.Workspace.Component.Query
  ) where

import SlamData.Prelude

import Control.Monad.Aff.AVar (makeVar, peekVar, takeVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Ref (readRef)
import Control.UI.Browser as Browser

import Data.List as List
import Data.Time.Duration (Milliseconds(..))

import DOM.Classy.Event (currentTarget, target) as DOM
import DOM.Classy.Node (toNode) as DOM

import Halogen as H

import Halogen.Component.Utils (busEventSource)
import Halogen.Component.Utils.Throttled (throttledEventSource_)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Guide.StepByStep.Component as Guide
import SlamData.Header.Component as Header
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar as Quasar
import SlamData.Quasar.Auth.Authentication as Authentication
import SlamData.Quasar.Error as QE
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Component.ChildSlot (ChildQuery, ChildSlot, cpDeck, cpGuide, cpHeader, cpNotify)
import SlamData.Workspace.Component.Query (Query(..))
import SlamData.Workspace.Component.State (State, initialState)
import SlamData.Workspace.Deck.Component as Deck
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide (GuideType(..))
import SlamData.Workspace.Guide as GuideData
import SlamData.Workspace.StateMode (StateMode(..))

import Utils (endSentence)
import Utils.DOM (onResize, nodeEq)
import Utils.LocalStorage as LocalStorage

type WorkspaceHTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type WorkspaceDSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ AT.AccessType → H.Component HH.HTML Query Unit Void Slam
component accessType =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render: render accessType
    , eval
    , initializer: Just $ Init unit
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ AT.AccessType → State → WorkspaceHTML
render accessType state =
  HH.div
    [ HP.classes
        $ (guard (AT.isReadOnly accessType) $> HH.ClassName "sd-published")
        ⊕ [ HH.ClassName "sd-workspace" ]
    , HE.onClick (HE.input DismissAll)
    ]
    (header ⊕ deck ⊕ notifications ⊕ renderCardGuide ⊕ renderFlipGuide)
  where
  renderError err =
    HH.div
      [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
      [ HH.h1_
          [ HH.text "Couldn't load this SlamData workspace." ]
      , HH.p_
          [ HH.text $ endSentence $ QE.printQError err ]
      , if (QE.isUnauthorized err)
          then HH.p_ (renderSignInButton <$> state.providers)
          else HH.text ""
      ]

  renderSignInButton providerR =
      HH.button
        [ HE.onClick $ HE.input_ $ SignIn providerR
        , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
        , HP.type_ HP.ButtonButton
        ]
        [ HH.text $ "Sign in with " ⊕ providerR.displayName ]

  renderCardGuide =
    pure $
      HH.div
        [ HP.classes (guard (state.guide /= Just CardGuide) $> B.hidden) ]
        [ HH.slot' cpGuide CardGuide Guide.component GuideData.cardGuideSteps (HE.input (HandleGuideMessage CardGuide)) ]

  renderFlipGuide =
    pure $
      HH.div
        [ HP.classes (guard (state.guide /= Just FlipGuide) $> B.hidden) ]
        [ HH.slot' cpGuide FlipGuide Guide.component GuideData.flipGuideSteps (HE.input (HandleGuideMessage FlipGuide)) ]

  notifications =
    pure $ HH.slot' cpNotify unit (NC.component (NC.renderModeFromAccessType accessType)) unit (const Nothing)

  header = do
    guard $ AT.isEditable accessType
    pure $ HH.slot' cpHeader unit Header.component unit absurd

  deck =
    pure case state.stateMode, state.cursor of
      Error error, _ → renderError error
      Loading, _ →
        HH.div
          [ HP.class_ $ HH.ClassName "sd-pending-overlay" ]
          [ HH.div_
              [ HH.i_ []
              , HH.span_ [ HH.text "Please wait while the workspace loads" ]
              ]
          ]
      _, List.Cons deckId cursor →
        HH.slot' cpDeck deckId (Deck.component { accessType, cursor, displayCursor: mempty, deckId }) unit (const Nothing)
      _, _ → HH.text "Error"

eval ∷ Query ~> WorkspaceDSL
eval = case _ of
  Init next → do
    { bus, accessType } ← H.lift Wiring.expose
    cardGuideStep ← initialCardGuideStep
    -- TODO:
    -- when (AT.isEditable accessType) do
    --   H.modify _ { cardGuideStep = cardGuideStep }
    H.subscribe $ busEventSource (H.request ∘ PresentStepByStepGuide) bus.stepByStep
    H.subscribe $ throttledEventSource_ (Milliseconds 100.0) onResize (H.request Resize)
    when (isNothing cardGuideStep) do
      void $ queryDeck $ H.action Deck.DismissedCardGuide
    pure next
  PresentStepByStepGuide guideType reply → do
    H.modify (_ { guide = Just guideType })
    pure $ reply H.Listening
  DismissAll ev next → do
    void $ H.query' cpHeader unit $ H.action Header.Dismiss
    eq ← H.liftEff $ nodeEq (DOM.toNode (DOM.target ev)) (DOM.toNode (DOM.currentTarget ev))
    when eq $ void $ queryDeck $ H.action Deck.Focus
    pure next
  Resize reply → do
    queryDeck (H.action Deck.UpdateCardSize)
    pure $ reply H.Listening
  New next → do
    st ← H.get
    when (List.null st.cursor) do
      runFreshWorkspace mempty
    pure next
  ExploreFile res next → do
    st ← H.get
    when (List.null st.cursor) do
      runFreshWorkspace
        [ CM.Open (R.File res)
        , CM.Table JT.emptyModel
        ]
    pure next
  Load cursor next → do
    st ← H.get
    case st.stateMode of
      Loading → do
        rootId ← H.lift P.loadWorkspace
        case rootId of
          Left err → do
            providers ←
              Quasar.retrieveAuthProviders <#> case _ of
                Right (Just providers) → providers
                _ → []
            H.modify _
              { stateMode = Error err
              , providers = providers
              }
            for_ (GE.fromQError err) GE.raiseGlobalError
          Right _ → loadCursor cursor
      _ → loadCursor cursor
    void $ queryDeck $ H.action Deck.Focus
    pure next
  SignIn providerR next → do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ takeVar idToken)
    pure next
  HandleGuideMessage slot Guide.Dismissed next → do
    case slot of
      CardGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedCardGuideKey true
        void $ queryDeck $ H.action Deck.DismissedCardGuide
      FlipGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedFlipGuideKey true
    H.modify (_ { guide = Nothing })
    pure next

  where
  loadCursor cursor = do
    cursor' ←
      if List.null cursor
        then do
          wiring ← H.lift Wiring.expose
          rootId ← H.liftAff $ peekVar wiring.eval.root
          pure (pure rootId)
        else
          hydrateCursor cursor
    H.modify _
      { stateMode = Ready
      , cursor = cursor'
      }

  hydrateCursor cursor = H.lift do
    wiring ← Wiring.expose
    ET.hydrateCursor
      <$> Cache.snapshot wiring.eval.decks
      <*> Cache.snapshot wiring.eval.cards
      <*> pure cursor

  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess $ auth.signIn
    H.liftEff Browser.reload

  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      for_ (Authentication.toNotificationOptions error) $
        flip Bus.write bus.notify
      Bus.write SignInFailure auth.signIn

runFreshWorkspace ∷ Array CM.AnyCardModel → WorkspaceDSL Unit
runFreshWorkspace cards = do
  { path, accessType, varMaps, bus } ← H.lift Wiring.expose
  deckId × cell ← H.lift $ P.freshWorkspace cards
  H.modify _
    { stateMode = Ready
    , cursor = pure deckId
    }
  void $ queryDeck $ H.action Deck.Focus
  let
    wait =
      H.liftAff (Bus.read cell.bus) >>= case _ of
        ED.Pending _ → wait
        ED.Complete _ _ → wait
        ED.CardComplete _ → wait
        ED.CardChange _ → H.gets _.cursor
        ED.NameChange _ → H.gets _.cursor
  cursor ← wait
  H.lift P.saveWorkspace
  urlVarMaps ← H.liftEff $ readRef varMaps
  navigate $ WorkspaceRoute path cursor (WA.Load accessType) urlVarMaps

-- TODO:
-- peek ∷ ∀ a. ChildQuery a → WorkspaceDSL Unit
-- peek = (const (pure unit)) ⨁ const (pure unit) ⨁ peekNotification
--   where
--   peekNotification ∷ NC.Query a → WorkspaceDSL Unit
--   peekNotification = case _ of
--     NC.Action N.ExpandGlobalMenu _ → do
--       queryHeaderGripper $ Gripper.StartDragging 0.0 unit
--       queryHeaderGripper $ Gripper.StopDragging unit
--     NC.Action (N.Fulfill var) _ →
--       void $ H.liftAff $ Aff.attempt $ putVar var unit
--     _ → pure unit

queryDeck ∷ ∀ a. Deck.Query a → WorkspaceDSL (Maybe a)
queryDeck q = do
  deckId ← H.gets (List.head ∘ _.cursor)
  join <$> for deckId \d → H.query' cpDeck d q

initialCardGuideStep ∷ WorkspaceDSL (Maybe Int)
initialCardGuideStep =
  H.lift
    $ either (const $ Just 0) (if _ then Nothing else Just 0)
    <$> LocalStorage.getLocalStorage GuideData.dismissedCardGuideKey


Remove dead subtype code

Remove dead subtype code

module IRGraph
    ( IRGraph(..)
    , Named(..)
    , namedValue
    , unifyNamed
    , mapToInferred
    , IRClassData(..)
    , IRType(..)
    , IRUnionRep(..)
    , irUnion_Nothing
    , irUnion_Null
    , irUnion_Integer
    , irUnion_Double
    , irUnion_Bool
    , irUnion_String
    , unionToList
    , Entry(..)
    , makeClass
    , emptyGraph
    , followIndex
    , getClassFromGraph
    , nullifyNothing
    , canBeNull
    , isArray
    , isClass
    , isMap
    , matchingProperties
    , mapClasses
    , classesInGraph
    , regatherClassNames
    , regatherUnionNames
    , filterTypes
    , removeNullFromUnion
    , nullableFromUnion
    , isUnionMember
    , forUnion_
    , mapUnionM
    , mapUnion
    , unionHasArray
    , unionHasClass
    , unionHasMap
    , emptyUnion
    ) where

import Prelude

import Control.Comonad (extract)
import Data.Identity (Identity(..))
import Data.Int.Bits as Bits
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust, maybe, fromMaybe)
import Data.Sequence as Seq
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

data Entry
    = NoType
    | Class IRClassData
    | Redirect Int

newtype IRGraph = IRGraph { classes :: Seq.Seq Entry, toplevels :: Map String IRType }

-- | Names for types are given or inferred.  Given names come from
-- | command line options and JSON Schema `title` properties.  Names
-- | are inferred from the property names for objects.  Given names
-- | always have priority over inferred names.
-- |
-- | `Named` is usually instantiated with a `Set String`, because
-- | classes can have more than one name.  With inferred names this is
-- | common, since we unify identical classes, and they might come from
-- | properties with different names.  It's also possible with given names:
-- | when the input is JSON Schema, one name for the top-level class could
-- | be given on the command line, the other could come from the `title`
-- | property in the schema.
data Named a
    = Given a
    | Inferred a

updateGiven :: forall a b. (Maybe a -> b) -> Named a -> Named b
updateGiven f (Given x) = Given $ f $ Just x
updateGiven f _ = Given $ f Nothing

updateInferred :: forall a. (a -> a) -> Named a -> Named a
updateInferred f (Inferred x) = Inferred $ f x
updateInferred _ given = given

namedValue :: forall a. Named a -> a
namedValue (Given x) = x
namedValue (Inferred x) = x

mapToInferred :: forall a b. (a -> b) -> Named a -> Named b
mapToInferred f n = Inferred $ f $ namedValue n

unifyNamed :: forall a. (a -> a -> a) -> Named a -> Named a -> Named a
unifyNamed f (Given ga) (Given gb) = Given $ f ga gb
unifyNamed f a@(Given _) _ = a
unifyNamed f _ b@(Given _) = b
unifyNamed f (Inferred ia) (Inferred ib) = Inferred $ f ia ib

instance functorNamed :: Functor Named where
    map f (Given x) = Given $ f x
    map f (Inferred x) = Inferred $ f x

-- | Classes have names and properties.  The choice of putting the names
-- | in the class data as opposed to keeping track of it separately is questionable,
-- | since names are subject to change, but properties aren't.  Also, we
-- | want the order of properties to be the same as the order in the original
-- | input, so we will have to switch from using `Map` to something else.  An
-- | order-preserving map would be nice.
newtype IRClassData = IRClassData { names :: Named (Set String), properties :: Map String IRType }

-- | Unions have names and a set of constituent types.  The set is implemented
-- | in a specialized way to make union operations more efficient.
-- |
-- | `primitives` is a bit set, with constants for elements defined below.
newtype IRUnionRep = IRUnionRep
    { names :: Named (Set String)
    , primitives :: Int
    , arrayType :: Maybe IRType
    , classRef :: Maybe Int
    , mapType :: Maybe IRType
    }

irUnion_Nothing :: Int
irUnion_Nothing = 1
irUnion_Null :: Int
irUnion_Null = 2
irUnion_Integer :: Int
irUnion_Integer = 4
irUnion_Double :: Int
irUnion_Double = 8
irUnion_Bool :: Int
irUnion_Bool = 16
irUnion_String :: Int
irUnion_String = 32

-- | The representation of types.
-- |
-- | `IRClass` is an integer indexing `IRGraph`'s `classes`.  This has some issues,
-- | and in any case is an implementation detail that should be hidden from
-- | higher-level users like the language renderers.
-- |
-- | `IRAnything` was a bad design choice and will go away.  See issue #56.
data IRType
    = IRAnything
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRMap IRType
    | IRUnion IRUnionRep

derive instance eqNamed :: Eq a => Eq (Named a)
derive instance ordNamed :: Ord a => Ord (Named a)
derive instance eqEntry :: Eq Entry
derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType
derive instance eqIRClassData :: Eq IRClassData
derive instance ordIRClassData :: Ord IRClassData
derive instance eqIRUnionRep :: Eq IRUnionRep
derive instance ordIRUnionRep :: Ord IRUnionRep
derive instance eqGraph :: Eq IRGraph

makeClass :: Named String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: map S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: Seq.empty, toplevels: M.empty }

followIndex :: IRGraph -> Int -> Tuple Int IRClassData
followIndex graph@(IRGraph { classes }) index =
    unsafePartial $
        case fromJust $ Seq.index index classes of
        Class cd -> Tuple index cd
        Redirect i -> followIndex graph i

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph index = T.snd $ followIndex graph index

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) = L.concat $ L.mapWithIndex mapper (L.fromFoldable classes)
    where
        mapper _ NoType = L.Nil
        mapper _ (Redirect _) = L.Nil
        mapper i (Class cd) = (f i cd) : L.Nil

mapClassesInSeq :: (Int -> IRClassData -> IRClassData) -> Seq.Seq Entry -> Seq.Seq Entry
mapClassesInSeq f entries =
    Seq.fromFoldable $ L.mapWithIndex entryMapper $ L.fromFoldable entries
    where
        entryMapper i (Class cd) = Class $ f i cd
        entryMapper _ x = x

classesInGraph :: IRGraph -> List (Tuple Int IRClassData)
classesInGraph = mapClasses Tuple

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

isMap :: IRType -> Boolean
isMap (IRMap _) = true
isMap _ = false

nullifyNothing :: IRType -> IRType
nullifyNothing IRAnything = IRNull
nullifyNothing x = x

canBeNull :: IRType -> Boolean
canBeNull =
    case _ of
    IRAnything -> true
    IRNull -> true
    -- FIXME: shouldn't we check for IRAnything in union, too?
    IRUnion (IRUnionRep { primitives }) -> (Bits.and primitives irUnion_Null) /= 0
    _ -> false

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb = M.fromFoldable $ L.concatMap getFromB (M.toUnfoldable ma)
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb | va == vb -> Tuple k vb : L.Nil
                    | otherwise -> L.Nil
            Nothing -> L.Nil

regatherClassNames :: IRGraph -> IRGraph
regatherClassNames graph@(IRGraph { classes, toplevels }) =
    -- FIXME: gather names from top levels map, too
    IRGraph { classes: mapClassesInSeq classMapper classes, toplevels }
    where
        newNames = combine $ mapClasses gatherFromClassData graph
        classMapper :: Int -> IRClassData -> IRClassData
        classMapper i (IRClassData { names, properties }) =
            let newNamesForClass = updateInferred (\old -> fromMaybe old $ M.lookup i newNames) names
            in IRClassData { names: newNamesForClass, properties}
        gatherFromClassData :: Int -> IRClassData -> Map Int (Set String)
        gatherFromClassData _ (IRClassData { properties }) =
            combine $ map (\(Tuple n t) -> gatherFromType n t) (M.toUnfoldable properties :: List (Tuple String IRType))
        combine :: List (Map Int (Set String)) -> Map Int (Set String)
        combine =
            L.foldr (M.unionWith S.union) M.empty
        gatherFromType :: String -> IRType -> Map Int (Set String)
        gatherFromType name t =
            case t of
            IRClass i -> M.singleton i (S.singleton name)
            IRArray a -> gatherFromType (singular name) a
            IRMap m -> gatherFromType (singular name) m
            IRUnion (IRUnionRep { arrayType, classRef, mapType }) ->
                let fromArray = maybe M.empty (gatherFromType name) arrayType
                    fromMap = maybe M.empty (gatherFromType name) mapType
                    fromClass = maybe M.empty (\i -> gatherFromType name $ IRClass i) classRef
                in
                    combine $ (fromArray : fromMap : fromClass : L.Nil)
            _ -> M.empty

regatherUnionNames :: IRGraph -> IRGraph
regatherUnionNames graph@(IRGraph { classes, toplevels }) =
    let newClasses = mapClassesInSeq (const classMapper) classes
        newTopLevels = M.mapWithKey (updateType <<< Given) toplevels
    in
        IRGraph { classes: newClasses, toplevels: newTopLevels }
    where
        classMapper (IRClassData { names, properties }) =
            IRClassData { names, properties: M.mapWithKey (updateType <<< Inferred) properties }
        reassign name names =
            case name of
            Given g -> updateGiven (maybe (S.singleton g) (S.insert g)) names
            Inferred i -> updateInferred (const $ S.singleton i) names
        updateType :: Named String -> IRType -> IRType
        updateType name t =
            case t of
            IRArray a -> IRArray $ updateType name a
            IRMap m -> IRMap $ updateType name m
            IRUnion (IRUnionRep { names, primitives, arrayType, classRef, mapType}) ->
                let newNames = reassign name names
                    singularName = mapToInferred singular name
                    newArrayType = map (updateType singularName) arrayType
                    newMapType = map (updateType singularName) mapType
                in
                    IRUnion $ IRUnionRep { names: newNames, primitives, arrayType: newArrayType, classRef, mapType: newMapType }
            _ -> t

removeNullFromUnion :: IRUnionRep -> { hasNull :: Boolean, nonNullUnion :: IRUnionRep }
removeNullFromUnion union@(IRUnionRep ur@{ primitives }) =
    if (Bits.and irUnion_Null primitives) == 0 then
        { hasNull: false, nonNullUnion: union }
    else
        { hasNull: true, nonNullUnion: IRUnionRep $ ur { primitives = Bits.xor irUnion_Null primitives }}

unionHasArray :: IRUnionRep -> Maybe IRType
unionHasArray (IRUnionRep { arrayType }) = map IRArray arrayType

unionHasClass :: IRUnionRep -> Maybe IRType
unionHasClass (IRUnionRep { classRef }) = map IRClass classRef

unionHasMap :: IRUnionRep -> Maybe IRType
unionHasMap (IRUnionRep { mapType }) = map IRMap mapType

nullableFromUnion :: IRUnionRep -> Maybe IRType
nullableFromUnion union =
    let { hasNull, nonNullUnion } = removeNullFromUnion union
    in
        if hasNull then
            case unionToList nonNullUnion of
            x : L.Nil -> Just x
            _ -> Nothing
        else
            Nothing

forUnion_ :: forall m. Monad m => IRUnionRep -> (IRType -> m Unit) -> m Unit
forUnion_ (IRUnionRep { primitives, arrayType, classRef, mapType }) f = do
    when (inPrimitives irUnion_Nothing) do f IRAnything
    when (inPrimitives irUnion_Null) do f IRNull
    when (inPrimitives irUnion_Integer) do f IRInteger
    when (inPrimitives irUnion_Double) do f IRDouble
    when (inPrimitives irUnion_Bool) do f IRBool
    when (inPrimitives irUnion_String) do f IRString
    case arrayType of
        Just a -> do f $ IRArray a
        Nothing -> pure unit
    case classRef of
        Just i -> do f $ IRClass i
        Nothing -> pure unit
    case mapType of
        Just m -> do f $ IRMap m
        Nothing -> pure unit
    where
        inPrimitives bit = (Bits.and bit primitives) /= 0

mapUnionM :: forall a m. Monad m => (IRType -> m a) -> IRUnionRep -> m (List a)
mapUnionM f (IRUnionRep { primitives, arrayType, classRef, mapType }) = do
    pure L.Nil
        >>= mapGeneral mapType IRMap
        >>= mapGeneral classRef IRClass
        >>= mapGeneral arrayType IRArray
        >>= mapPrimitive irUnion_String IRString
        >>= mapPrimitive irUnion_Bool IRBool
        >>= mapPrimitive irUnion_Double IRDouble
        >>= mapPrimitive irUnion_Integer IRInteger
        >>= mapPrimitive irUnion_Null IRNull
        >>= mapPrimitive irUnion_Nothing IRAnything
    where
        mapPrimitive :: Int -> IRType -> List a -> m (List a)
        mapPrimitive bit t l =
            if (Bits.and bit primitives) /= 0 then do
                result <- f t
                pure $ result : l
            else
                pure l

        mapGeneral :: forall x. Maybe x -> (x -> IRType) -> List a -> m (List a)
        mapGeneral Nothing _ l = pure l
        mapGeneral (Just x) convert l = do
            result <- f $ convert x
            pure $ result : l

mapUnion :: forall a. (IRType -> a) -> IRUnionRep -> List a
mapUnion f = extract <<< mapUnionM (Identity <<< f)

unionToList :: IRUnionRep -> List IRType
unionToList = mapUnion id

isUnionMember :: IRType -> IRUnionRep -> Boolean
isUnionMember t (IRUnionRep { primitives, arrayType, classRef, mapType }) =
    case t of
    IRAnything -> inPrimitives irUnion_Nothing
    IRNull -> inPrimitives irUnion_Null
    IRInteger -> inPrimitives irUnion_Integer
    IRDouble -> inPrimitives irUnion_Double
    IRBool -> inPrimitives irUnion_Bool
    IRString -> inPrimitives irUnion_String
    IRArray a -> maybe false (eq a) arrayType
    IRClass i -> maybe false (eq i) classRef
    IRMap m -> maybe false (eq m) mapType
    IRUnion _ -> false
    where
        inPrimitives bit = (Bits.and bit primitives) /= 0

filterTypes :: forall a. Ord a => (IRType -> Maybe a) -> IRGraph -> Set a
filterTypes predicate graph@(IRGraph { classes, toplevels }) =
    let fromTopLevels = S.unions $ map filterType $ M.values toplevels
        fromGraph = S.unions $ mapClasses (\_ cd -> filterClass cd) graph
    in
        S.union fromTopLevels fromGraph
    where
        filterClass :: IRClassData -> Set a
        filterClass (IRClassData { properties }) =
            S.unions $ map filterType $ M.values properties
        recurseType t =
            case t of
            IRArray t' -> filterType t'
            IRMap t' -> filterType t'
            IRUnion r ->
                S.unions $ mapUnion filterType r
            _ -> S.empty
        filterType :: IRType -> Set a
        filterType t =
            let l = recurseType t
            in
                case predicate t of
                Nothing -> l
                Just x -> S.insert x l

emptyUnion :: IRUnionRep
emptyUnion =
    IRUnionRep { names: Inferred $ S.empty, primitives: 0, arrayType: Nothing, classRef: Nothing, mapType: Nothing }

module IRGraph
    ( IRGraph(..)
    , Named(..)
    , namedValue
    , unifyNamed
    , mapToInferred
    , IRClassData(..)
    , IRType(..)
    , IRUnionRep(..)
    , irUnion_Nothing
    , irUnion_Null
    , irUnion_Integer
    , irUnion_Double
    , irUnion_Bool
    , irUnion_String
    , unionToList
    , Entry(..)
    , makeClass
    , emptyGraph
    , followIndex
    , getClassFromGraph
    , nullifyNothing
    , canBeNull
    , isArray
    , isClass
    , isMap
    , matchingProperties
    , mapClasses
    , classesInGraph
    , regatherClassNames
    , regatherUnionNames
    , filterTypes
    , removeNullFromUnion
    , nullableFromUnion
    , isUnionMember
    , forUnion_
    , mapUnionM
    , mapUnion
    , unionHasArray
    , unionHasClass
    , unionHasMap
    , emptyUnion
    ) where

import Prelude

import Control.Comonad (extract)
import Data.Foldable (all)
import Data.Identity (Identity(..))
import Data.Int.Bits as Bits
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust, maybe, fromMaybe)
import Data.Sequence as Seq
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

data Entry
    = NoType
    | Class IRClassData
    | Redirect Int

newtype IRGraph = IRGraph { classes :: Seq.Seq Entry, toplevels :: Map String IRType }

-- | Names for types are given or inferred.  Given names come from
-- | command line options and JSON Schema `title` properties.  Names
-- | are inferred from the property names for objects.  Given names
-- | always have priority over inferred names.
-- |
-- | `Named` is usually instantiated with a `Set String`, because
-- | classes can have more than one name.  With inferred names this is
-- | common, since we unify identical classes, and they might come from
-- | properties with different names.  It's also possible with given names:
-- | when the input is JSON Schema, one name for the top-level class could
-- | be given on the command line, the other could come from the `title`
-- | property in the schema.
data Named a
    = Given a
    | Inferred a

updateGiven :: forall a b. (Maybe a -> b) -> Named a -> Named b
updateGiven f (Given x) = Given $ f $ Just x
updateGiven f _ = Given $ f Nothing

updateInferred :: forall a. (a -> a) -> Named a -> Named a
updateInferred f (Inferred x) = Inferred $ f x
updateInferred _ given = given

namedValue :: forall a. Named a -> a
namedValue (Given x) = x
namedValue (Inferred x) = x

mapToInferred :: forall a b. (a -> b) -> Named a -> Named b
mapToInferred f n = Inferred $ f $ namedValue n

unifyNamed :: forall a. (a -> a -> a) -> Named a -> Named a -> Named a
unifyNamed f (Given ga) (Given gb) = Given $ f ga gb
unifyNamed f a@(Given _) _ = a
unifyNamed f _ b@(Given _) = b
unifyNamed f (Inferred ia) (Inferred ib) = Inferred $ f ia ib

instance functorNamed :: Functor Named where
    map f (Given x) = Given $ f x
    map f (Inferred x) = Inferred $ f x

-- | Classes have names and properties.  The choice of putting the names
-- | in the class data as opposed to keeping track of it separately is questionable,
-- | since names are subject to change, but properties aren't.  Also, we
-- | want the order of properties to be the same as the order in the original
-- | input, so we will have to switch from using `Map` to something else.  An
-- | order-preserving map would be nice.
newtype IRClassData = IRClassData { names :: Named (Set String), properties :: Map String IRType }

-- | Unions have names and a set of constituent types.  The set is implemented
-- | in a specialized way to make union operations more efficient.
-- |
-- | `primitives` is a bit set, with constants for elements defined below.
newtype IRUnionRep = IRUnionRep
    { names :: Named (Set String)
    , primitives :: Int
    , arrayType :: Maybe IRType
    , classRef :: Maybe Int
    , mapType :: Maybe IRType
    }

irUnion_Nothing :: Int
irUnion_Nothing = 1
irUnion_Null :: Int
irUnion_Null = 2
irUnion_Integer :: Int
irUnion_Integer = 4
irUnion_Double :: Int
irUnion_Double = 8
irUnion_Bool :: Int
irUnion_Bool = 16
irUnion_String :: Int
irUnion_String = 32

-- | The representation of types.
-- |
-- | `IRClass` is an integer indexing `IRGraph`'s `classes`.  This has some issues,
-- | and in any case is an implementation detail that should be hidden from
-- | higher-level users like the language renderers.
-- |
-- | `IRAnything` was a bad design choice and will go away.  See issue #56.
data IRType
    = IRAnything
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRMap IRType
    | IRUnion IRUnionRep

derive instance eqNamed :: Eq a => Eq (Named a)
derive instance ordNamed :: Ord a => Ord (Named a)
derive instance eqEntry :: Eq Entry
derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType
derive instance eqIRClassData :: Eq IRClassData
derive instance ordIRClassData :: Ord IRClassData
derive instance eqIRUnionRep :: Eq IRUnionRep
derive instance ordIRUnionRep :: Ord IRUnionRep
derive instance eqGraph :: Eq IRGraph

makeClass :: Named String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: map S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: Seq.empty, toplevels: M.empty }

followIndex :: IRGraph -> Int -> Tuple Int IRClassData
followIndex graph@(IRGraph { classes }) index =
    unsafePartial $
        case fromJust $ Seq.index index classes of
        Class cd -> Tuple index cd
        Redirect i -> followIndex graph i

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph index = T.snd $ followIndex graph index

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) = L.concat $ L.mapWithIndex mapper (L.fromFoldable classes)
    where
        mapper _ NoType = L.Nil
        mapper _ (Redirect _) = L.Nil
        mapper i (Class cd) = (f i cd) : L.Nil

mapClassesInSeq :: (Int -> IRClassData -> IRClassData) -> Seq.Seq Entry -> Seq.Seq Entry
mapClassesInSeq f entries =
    Seq.fromFoldable $ L.mapWithIndex entryMapper $ L.fromFoldable entries
    where
        entryMapper i (Class cd) = Class $ f i cd
        entryMapper _ x = x

classesInGraph :: IRGraph -> List (Tuple Int IRClassData)
classesInGraph = mapClasses Tuple

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

isMap :: IRType -> Boolean
isMap (IRMap _) = true
isMap _ = false

nullifyNothing :: IRType -> IRType
nullifyNothing IRAnything = IRNull
nullifyNothing x = x

canBeNull :: IRType -> Boolean
canBeNull =
    case _ of
    IRAnything -> true
    IRNull -> true
    -- FIXME: shouldn't we check for IRAnything in union, too?
    IRUnion (IRUnionRep { primitives }) -> (Bits.and primitives irUnion_Null) /= 0
    _ -> false

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb = M.fromFoldable $ L.concatMap getFromB (M.toUnfoldable ma)
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb | va == vb -> Tuple k vb : L.Nil
                    | otherwise -> L.Nil
            Nothing -> L.Nil

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubclassOf :: IRGraph -> Int -> Int -> Boolean
isSubclassOf graph ia ib =
    let IRClassData { properties: pa } = getClassFromGraph graph ia
        IRClassData { properties: pb } = getClassFromGraph graph ib
    in propertiesAreSubset pa pb
    where
        propertiesAreSubset :: Map String IRType -> Map String IRType -> Boolean
        propertiesAreSubset ma mb = all (isInB mb) (M.toUnfoldable ma :: List (Tuple String IRType))
        isInB mb (Tuple n ta) = maybe false (isSubtypeOf graph ta) (M.lookup n mb)

-- FIXME: generalize with isMaybeSubtypeOfMaybe
isMaybeSubclassOfMaybe :: IRGraph -> Maybe Int -> Maybe Int -> Boolean
isMaybeSubclassOfMaybe _ Nothing Nothing = true
isMaybeSubclassOfMaybe graph (Just a) (Just b) = isSubclassOf graph a b
isMaybeSubclassOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRAnything _ = true
isSubtypeOf graph (IRUnion a) (IRUnion b) =
    let IRUnionRep { primitives: pa, arrayType: aa, classRef: ca, mapType: ma } = a
        IRUnionRep { primitives: pb, arrayType: ab, classRef: cb, mapType: mb } = a
    in
        (Bits.and pa pb) == pa &&
        isMaybeSubtypeOfMaybe graph aa ab &&
        isMaybeSubtypeOfMaybe graph ma mb &&
        isMaybeSubclassOfMaybe graph ca cb
isSubtypeOf graph (IRArray a) (IRArray b) = isSubtypeOf graph a b
isSubtypeOf graph (IRMap a) (IRMap b) = isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) = isSubclassOf graph ia ib
isSubtypeOf _ a b = a == b

regatherClassNames :: IRGraph -> IRGraph
regatherClassNames graph@(IRGraph { classes, toplevels }) =
    -- FIXME: gather names from top levels map, too
    IRGraph { classes: mapClassesInSeq classMapper classes, toplevels }
    where
        newNames = combine $ mapClasses gatherFromClassData graph
        classMapper :: Int -> IRClassData -> IRClassData
        classMapper i (IRClassData { names, properties }) =
            let newNamesForClass = updateInferred (\old -> fromMaybe old $ M.lookup i newNames) names
            in IRClassData { names: newNamesForClass, properties}
        gatherFromClassData :: Int -> IRClassData -> Map Int (Set String)
        gatherFromClassData _ (IRClassData { properties }) =
            combine $ map (\(Tuple n t) -> gatherFromType n t) (M.toUnfoldable properties :: List (Tuple String IRType))
        combine :: List (Map Int (Set String)) -> Map Int (Set String)
        combine =
            L.foldr (M.unionWith S.union) M.empty
        gatherFromType :: String -> IRType -> Map Int (Set String)
        gatherFromType name t =
            case t of
            IRClass i -> M.singleton i (S.singleton name)
            IRArray a -> gatherFromType (singular name) a
            IRMap m -> gatherFromType (singular name) m
            IRUnion (IRUnionRep { arrayType, classRef, mapType }) ->
                let fromArray = maybe M.empty (gatherFromType name) arrayType
                    fromMap = maybe M.empty (gatherFromType name) mapType
                    fromClass = maybe M.empty (\i -> gatherFromType name $ IRClass i) classRef
                in
                    combine $ (fromArray : fromMap : fromClass : L.Nil)
            _ -> M.empty

regatherUnionNames :: IRGraph -> IRGraph
regatherUnionNames graph@(IRGraph { classes, toplevels }) =
    let newClasses = mapClassesInSeq (const classMapper) classes
        newTopLevels = M.mapWithKey (updateType <<< Given) toplevels
    in
        IRGraph { classes: newClasses, toplevels: newTopLevels }
    where
        classMapper (IRClassData { names, properties }) =
            IRClassData { names, properties: M.mapWithKey (updateType <<< Inferred) properties }
        reassign name names =
            case name of
            Given g -> updateGiven (maybe (S.singleton g) (S.insert g)) names
            Inferred i -> updateInferred (const $ S.singleton i) names
        updateType :: Named String -> IRType -> IRType
        updateType name t =
            case t of
            IRArray a -> IRArray $ updateType name a
            IRMap m -> IRMap $ updateType name m
            IRUnion (IRUnionRep { names, primitives, arrayType, classRef, mapType}) ->
                let newNames = reassign name names
                    singularName = mapToInferred singular name
                    newArrayType = map (updateType singularName) arrayType
                    newMapType = map (updateType singularName) mapType
                in
                    IRUnion $ IRUnionRep { names: newNames, primitives, arrayType: newArrayType, classRef, mapType: newMapType }
            _ -> t

removeNullFromUnion :: IRUnionRep -> { hasNull :: Boolean, nonNullUnion :: IRUnionRep }
removeNullFromUnion union@(IRUnionRep ur@{ primitives }) =
    if (Bits.and irUnion_Null primitives) == 0 then
        { hasNull: false, nonNullUnion: union }
    else
        { hasNull: true, nonNullUnion: IRUnionRep $ ur { primitives = Bits.xor irUnion_Null primitives }}

unionHasArray :: IRUnionRep -> Maybe IRType
unionHasArray (IRUnionRep { arrayType }) = map IRArray arrayType

unionHasClass :: IRUnionRep -> Maybe IRType
unionHasClass (IRUnionRep { classRef }) = map IRClass classRef

unionHasMap :: IRUnionRep -> Maybe IRType
unionHasMap (IRUnionRep { mapType }) = map IRMap mapType

nullableFromUnion :: IRUnionRep -> Maybe IRType
nullableFromUnion union =
    let { hasNull, nonNullUnion } = removeNullFromUnion union
    in
        if hasNull then
            case unionToList nonNullUnion of
            x : L.Nil -> Just x
            _ -> Nothing
        else
            Nothing

forUnion_ :: forall m. Monad m => IRUnionRep -> (IRType -> m Unit) -> m Unit
forUnion_ (IRUnionRep { primitives, arrayType, classRef, mapType }) f = do
    when (inPrimitives irUnion_Nothing) do f IRAnything
    when (inPrimitives irUnion_Null) do f IRNull
    when (inPrimitives irUnion_Integer) do f IRInteger
    when (inPrimitives irUnion_Double) do f IRDouble
    when (inPrimitives irUnion_Bool) do f IRBool
    when (inPrimitives irUnion_String) do f IRString
    case arrayType of
        Just a -> do f $ IRArray a
        Nothing -> pure unit
    case classRef of
        Just i -> do f $ IRClass i
        Nothing -> pure unit
    case mapType of
        Just m -> do f $ IRMap m
        Nothing -> pure unit
    where
        inPrimitives bit = (Bits.and bit primitives) /= 0

mapUnionM :: forall a m. Monad m => (IRType -> m a) -> IRUnionRep -> m (List a)
mapUnionM f (IRUnionRep { primitives, arrayType, classRef, mapType }) = do
    pure L.Nil
        >>= mapGeneral mapType IRMap
        >>= mapGeneral classRef IRClass
        >>= mapGeneral arrayType IRArray
        >>= mapPrimitive irUnion_String IRString
        >>= mapPrimitive irUnion_Bool IRBool
        >>= mapPrimitive irUnion_Double IRDouble
        >>= mapPrimitive irUnion_Integer IRInteger
        >>= mapPrimitive irUnion_Null IRNull
        >>= mapPrimitive irUnion_Nothing IRAnything
    where
        mapPrimitive :: Int -> IRType -> List a -> m (List a)
        mapPrimitive bit t l =
            if (Bits.and bit primitives) /= 0 then do
                result <- f t
                pure $ result : l
            else
                pure l

        mapGeneral :: forall x. Maybe x -> (x -> IRType) -> List a -> m (List a)
        mapGeneral Nothing _ l = pure l
        mapGeneral (Just x) convert l = do
            result <- f $ convert x
            pure $ result : l

mapUnion :: forall a. (IRType -> a) -> IRUnionRep -> List a
mapUnion f = extract <<< mapUnionM (Identity <<< f)

unionToList :: IRUnionRep -> List IRType
unionToList = mapUnion id

isUnionMember :: IRType -> IRUnionRep -> Boolean
isUnionMember t (IRUnionRep { primitives, arrayType, classRef, mapType }) =
    case t of
    IRAnything -> inPrimitives irUnion_Nothing
    IRNull -> inPrimitives irUnion_Null
    IRInteger -> inPrimitives irUnion_Integer
    IRDouble -> inPrimitives irUnion_Double
    IRBool -> inPrimitives irUnion_Bool
    IRString -> inPrimitives irUnion_String
    IRArray a -> maybe false (eq a) arrayType
    IRClass i -> maybe false (eq i) classRef
    IRMap m -> maybe false (eq m) mapType
    IRUnion _ -> false
    where
        inPrimitives bit = (Bits.and bit primitives) /= 0

filterTypes :: forall a. Ord a => (IRType -> Maybe a) -> IRGraph -> Set a
filterTypes predicate graph@(IRGraph { classes, toplevels }) =
    let fromTopLevels = S.unions $ map filterType $ M.values toplevels
        fromGraph = S.unions $ mapClasses (\_ cd -> filterClass cd) graph
    in
        S.union fromTopLevels fromGraph
    where
        filterClass :: IRClassData -> Set a
        filterClass (IRClassData { properties }) =
            S.unions $ map filterType $ M.values properties
        recurseType t =
            case t of
            IRArray t' -> filterType t'
            IRMap t' -> filterType t'
            IRUnion r ->
                S.unions $ mapUnion filterType r
            _ -> S.empty
        filterType :: IRType -> Set a
        filterType t =
            let l = recurseType t
            in
                case predicate t of
                Nothing -> l
                Just x -> S.insert x l

emptyUnion :: IRUnionRep
emptyUnion =
    IRUnionRep { names: Inferred $ S.empty, primitives: 0, arrayType: Nothing, classRef: Nothing, mapType: Nothing }


Make import list explicit

Make import list explicit

module Data.PhoneBook where

import Data.List
import Data.Maybe

import Control.Plus (empty)

type Entry = { firstName :: String, lastName :: String, phone :: String }

type PhoneBook = List Entry

showEntry :: Entry -> String
showEntry entry = entry.lastName ++ ", " ++ entry.firstName ++ ": " ++ entry.phone

emptyBook :: PhoneBook
emptyBook = empty

insertEntry :: Entry -> PhoneBook -> PhoneBook
insertEntry = Cons

findEntry :: String -> String -> PhoneBook -> Maybe Entry
findEntry firstName lastName = head <<< filter filterEntry
  where
  filterEntry :: Entry -> Boolean
  filterEntry entry = entry.firstName == firstName && entry.lastName == lastName

module Data.PhoneBook where

import Data.List
import Data.Maybe

import Control.Plus

type Entry = { firstName :: String, lastName :: String, phone :: String }

type PhoneBook = List Entry

showEntry :: Entry -> String
showEntry entry = entry.lastName ++ ", " ++ entry.firstName ++ ": " ++ entry.phone

emptyBook :: PhoneBook
emptyBook = empty

insertEntry :: Entry -> PhoneBook -> PhoneBook
insertEntry = Cons

findEntry :: String -> String -> PhoneBook -> Maybe Entry
findEntry firstName lastName = head <<< filter filterEntry
  where
  filterEntry :: Entry -> Boolean
  filterEntry entry = entry.firstName == firstName && entry.lastName == lastName


Move 'defer' only to where needed

Move 'defer' only to where needed

module Language.Docopt.SpecParser.Usage (
    usageParser
  , run
  , parse
  , module U
  ) where

import Prelude
import Debug.Trace
import Debug.Profile
import Data.Functor (($>))
import Language.Docopt.SpecParser.Lexer as L
import Language.Docopt.SpecParser.Usage.Option as O
import Language.Docopt.SpecParser.Usage.Usage as U
import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Control.Bind ((=<<))
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Data.Either (Either)
import Data.List (List(..), many, some, singleton, length, modifyAt)
import Data.Maybe (fromMaybe, Maybe(..), maybe, isNothing)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested (tuple3)
import Language.Docopt.SpecParser.Common (markIndent', markLine, indented,
                                     sameIndent, lessIndented, moreIndented)
import Language.Docopt.SpecParser.Usage.Argument (Argument(..))
import Language.Docopt.SpecParser.Usage.Usage (Usage(..))
import Text.Parsing.Parser (ParseError) as P
import Text.Parsing.Parser.Combinators (try, optional, choice, sepBy1, between,
                                       optionMaybe, lookAhead, option) as P
import Text.Parsing.Parser.Combinators ((<?>), (<??>))
import Text.Parsing.Parser.Pos (Position(Position)) as P

-- | TokenParser to parse the usage section
-- |
-- | This parser is tricky because it has to solve the following problems:
-- |    * What is the program name?
-- |    * Disambiguate between a usage and random text.
-- |    * Disambiguate between a usage and a line-wrapped usage.
-- |
-- | Hence, the following approach is employed:
-- |    * The parser expects a valid program name as first token
-- |    * The parser marks the indent of the first program name
-- |    * Tokens past the identation mark are considered to be part of the
-- |      previous usage pattern.
-- |    * Tokens before the identation mark are NOT considered interesting and
-- |      are IGNORED.
-- |    * A token at the identation mark starts a new usage pattern parse.
-- |
usageParser :: Boolean -- ^ Enable "smart-options" parsing
            -> L.TokenParser (List Usage)
usageParser smartOpts = do

  -- Calculate and mark the original program indentation.
  P.Position { column: startCol } <- L.nextTokPos <?> "Program name"
  name <- program
  markLine do
    markIndent' startCol $ do
      Cons
      <$> (usageLine name)
      <*> many do
            P.optional $ P.try do
              L.name >>= guard <<< (_ == "or")
              L.colon
            program
            usageLine name
  <* (L.eof <?> "End of usage section")

  where

    usageLine :: String -> L.TokenParser Usage
    usageLine name = Usage name <$> do
      xs <- "Option, Positional, Command, Group or Reference elements" <??> do
                  (many $ P.try $ moreIndented *> elem) `P.sepBy1` L.vbar
      eoa <- P.choice [
        P.try $ do
          maybeInParens do
            maybeInParens do
              L.doubleDash
              many elem
            many elem
          many elem
          pure $ Just EOA
      , (do
          L.eof <|> (P.lookAhead $ lessIndented <|> sameIndent)
          pure Nothing
        )
        -- XXX: We could show the last token that failed to be consumed, here
        <?> "End of usage line"
      ]

      -- Push the EOA onto the last branch (the most right branch)
      pure $ maybe xs id do
        e <- eoa
        modifyAt
          (length xs - 1)
          (\as -> as <> (singleton e))
          xs

    maybeInParens p = do
      Tuple close v <- moreIndented *> do
        Tuple
          <$> (P.optionMaybe $ P.choice [ L.lparen  $> L.rparen
                                        , L.lsquare $> L.rsquare ])
          <*> p
      fromMaybe (pure unit) close
      pure v

    elem :: L.TokenParser Argument
    elem = "Option, Positional, Command, Group or Reference" <??>
      (P.choice
        [ positional
        , command
        , reference
        , stdin
        , option
        , defer \_ -> (if smartOpts then trySmartOpt else id) <$> group
        ])

    trySmartOpt :: Argument -> Argument
    trySmartOpt grp'@(Group grp) = fromMaybe grp' $ do
      Tuple opt optarg <- case grp.branches of
                              (Cons (Cons opt' (Cons arg' Nil)) Nil) ->
                                pure $ Tuple opt' arg'
                              otherwise -> Nothing

      optf <- do
        case opt of
              (Option o) | isNothing o.arg ->
                pure $ \argName isArgOptional isRepeatable ->
                  Option $ o {
                    arg = pure {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              (OptionStack o) | isNothing o.arg ->
                pure $ \argName isArgOptional isRepeatable ->
                  OptionStack $ o {
                    arg = pure {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              otherwise -> Nothing

      (Tuple (Tuple name isRepeatable) isOptional) <- do
        case optarg of
              (Positional pos) ->
                pure $ tuple3 pos.name
                              (pos.repeatable || grp.repeatable)
                              false
              (Command cmd) ->
                pure $ tuple3 cmd.name
                              (cmd.repeatable || grp.repeatable)
                              false
              (Group (grp''@{ branches: Cons (Cons a Nil) Nil })) ->
                case a of
                  (Positional pos) ->
                    pure $ tuple3 pos.name
                                  (pos.repeatable || grp''.repeatable)
                                  grp''.optional
                  (Command cmd) ->
                    pure $ tuple3 cmd.name
                                  (cmd.repeatable || grp''.repeatable)
                                  grp''.optional
                  otherwise -> Nothing
              otherwise -> Nothing

      pure $ Group grp {
        branches = singleton $ singleton (optf name isOptional isRepeatable)
      }
    trySmartOpt x = x

    stdin :: L.TokenParser Argument
    stdin = L.dash *> pure Stdin

    longOption :: L.TokenParser Argument
    longOption = Option <$> do
      { name, arg } <- L.lopt
      r <- repetition
      pure  { name:       name
            , arg:        arg
            , repeatable: r
            }

    shortOption :: L.TokenParser Argument
    shortOption = OptionStack <$> do
      { flag, stack, arg } <- L.sopt
      r <- repetition
      pure  { flag:       flag
            , stack:      stack
            , arg:        arg
            , repeatable: r
            }

    option :: L.TokenParser Argument
    option = longOption <|> shortOption

    reference :: L.TokenParser Argument
    reference = Reference <$> L.reference

    positional :: L.TokenParser Argument
    positional = Positional <$> do
      name <- L.shoutName <|> L.angleName
      r    <- repetition
      pure { name: name, repeatable: r }

    command :: L.TokenParser Argument
    command = Command <$> do
      name <-  L.name
      r    <- repetition
      pure { name: name, repeatable: r }

    group :: L.TokenParser Argument
    group = defer \_ -> P.choice [ reqGroup , optGroup ]

    optGroup :: L.TokenParser Argument
    optGroup = defer \_ -> Group <$> do
      branches <- P.between
                    (indented *> L.lsquare)
                    (L.rsquare)
                    ((some elem) `P.sepBy1` L.vbar)
      r <- repetition
      pure { optional: true, branches: branches, repeatable: r }

    reqGroup :: L.TokenParser Argument
    reqGroup = defer \_ -> Group <$> do
      branches <- P.between
                    (indented *> L.lparen)
                    (L.rparen)
                    ((some elem) `P.sepBy1` L.vbar)
      r <- repetition
      pure { optional: false, branches: branches, repeatable: r }

    repetition :: L.TokenParser Boolean
    repetition = P.option false (indented *> L.tripleDot $> true)

    program :: L.TokenParser String
    program = "Program name" <??> L.name

parse :: Boolean                  -- ^ Enable "smart-options"
      -> (List L.PositionedToken) -- ^ The token stream
      -> Either P.ParseError (List Usage)
parse smartOpts = flip L.runTokenParser (usageParser smartOpts)

run :: String  -- ^ The usage section text
    -> Boolean -- ^ Enable "smart-options"
    -> Either P.ParseError (List Usage)
run x smartOpts = parse smartOpts =<< L.lexUsage x

module Language.Docopt.SpecParser.Usage (
    usageParser
  , run
  , parse
  , module U
  ) where

import Prelude
import Debug.Trace
import Data.Functor (($>))
import Language.Docopt.SpecParser.Lexer as L
import Language.Docopt.SpecParser.Usage.Option as O
import Language.Docopt.SpecParser.Usage.Usage as U
import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Control.Bind ((=<<))
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Data.Either (Either)
import Data.List (List(..), many, some, singleton, length, modifyAt)
import Data.Maybe (fromMaybe, Maybe(..), maybe, isNothing)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested (tuple3)
import Language.Docopt.SpecParser.Common (markIndent', markLine, indented,
                                     sameIndent, lessIndented, moreIndented)
import Language.Docopt.SpecParser.Usage.Argument (Argument(..))
import Language.Docopt.SpecParser.Usage.Usage (Usage(..))
import Text.Parsing.Parser (ParseError) as P
import Text.Parsing.Parser.Combinators (try, optional, choice, sepBy1, between,
                                       optionMaybe, lookAhead, option) as P
import Text.Parsing.Parser.Combinators ((<?>), (<??>))
import Text.Parsing.Parser.Pos (Position(Position)) as P

-- | TokenParser to parse the usage section
-- |
-- | This parser is tricky because it has to solve the following problems:
-- |    * What is the program name?
-- |    * Disambiguate between a usage and random text.
-- |    * Disambiguate between a usage and a line-wrapped usage.
-- |
-- | Hence, the following approach is employed:
-- |    * The parser expects a valid program name as first token
-- |    * The parser marks the indent of the first program name
-- |    * Tokens past the identation mark are considered to be part of the
-- |      previous usage pattern.
-- |    * Tokens before the identation mark are NOT considered interesting and
-- |      are IGNORED.
-- |    * A token at the identation mark starts a new usage pattern parse.
-- |
usageParser :: Boolean -- ^ Enable "smart-options" parsing
            -> L.TokenParser (List Usage)
usageParser smartOpts = do

  -- Calculate and mark the original program indentation.
  P.Position { column: startCol } <- L.nextTokPos <?> "Program name"
  name <- program
  markLine do
    markIndent' startCol $ do
      Cons
      <$> (usageLine name)
      <*> many do
            P.optional $ P.try do
              L.name >>= guard <<< (_ == "or")
              L.colon
            program
            usageLine name
  <* (L.eof <?> "End of usage section")

  where

    usageLine :: String -> L.TokenParser Usage
    usageLine name = Usage name <$> do
      xs <- "Option, Positional, Command, Group or Reference elements" <??> do
                  (many $ P.try $ moreIndented *> elem) `P.sepBy1` L.vbar
      eoa <- P.choice [
        P.try $ do
          maybeInParens do
            maybeInParens do
              L.doubleDash
              many elem
            many elem
          many elem
          pure $ Just EOA
      , (do
          L.eof <|> (P.lookAhead $ lessIndented <|> sameIndent)
          pure Nothing
        )
        -- XXX: We could show the last token that failed to be consumed, here
        <?> "End of usage line"
      ]

      -- Push the EOA onto the last branch (the most right branch)
      pure $ maybe xs id do
        e <- eoa
        modifyAt
          (length xs - 1)
          (\as -> as <> (singleton e))
          xs

    maybeInParens p = do
      Tuple close v <- moreIndented *> do
        Tuple
          <$> (P.optionMaybe $ P.choice [ L.lparen  *> pure L.rparen
                                        , L.lsquare *> pure L.rsquare ])
          <*> p
      fromMaybe (pure unit) close
      pure v

    elem :: L.TokenParser Argument
    elem = defer \_ -> do
      (P.choice $ P.try <$>
        [ option
        , positional
        , command
        , (if smartOpts then trySmartOpt else id) <$> group
        , reference
        , stdin
        ]) <?> "Option, Positional, Command, Group or Reference"

    trySmartOpt :: Argument -> Argument
    trySmartOpt grp'@(Group grp) = fromMaybe grp' $ do
      Tuple opt optarg <- case grp.branches of
                              (Cons (Cons opt' (Cons arg' Nil)) Nil) ->
                                pure $ Tuple opt' arg'
                              otherwise -> Nothing

      optf <- do
        case opt of
              (Option o) | isNothing o.arg ->
                pure $ \argName isArgOptional isRepeatable ->
                  Option $ o {
                    arg = pure {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              (OptionStack o) | isNothing o.arg ->
                pure $ \argName isArgOptional isRepeatable ->
                  OptionStack $ o {
                    arg = pure {
                      name:     argName
                    , optional: isArgOptional
                    }
                  , repeatable = isRepeatable
                  }
              otherwise -> Nothing

      (Tuple (Tuple name isRepeatable) isOptional) <- do
        case optarg of
              (Positional pos) ->
                pure $ tuple3 pos.name
                              (pos.repeatable || grp.repeatable)
                              false
              (Command cmd) ->
                pure $ tuple3 cmd.name
                              (cmd.repeatable || grp.repeatable)
                              false
              (Group (grp''@{ branches: Cons (Cons a Nil) Nil })) ->
                case a of
                  (Positional pos) ->
                    pure $ tuple3 pos.name
                                  (pos.repeatable || grp''.repeatable)
                                  grp''.optional
                  (Command cmd) ->
                    pure $ tuple3 cmd.name
                                  (cmd.repeatable || grp''.repeatable)
                                  grp''.optional
                  otherwise -> Nothing
              otherwise -> Nothing

      pure $ Group grp {
        branches = singleton $ singleton (optf name isOptional isRepeatable)
      }
    trySmartOpt x = x

    stdin :: L.TokenParser Argument
    stdin = L.dash *> pure Stdin

    longOption :: L.TokenParser Argument
    longOption = Option <$> do
      { name, arg } <- L.lopt
      r <- repetition
      pure  { name:       name
            , arg:        arg
            , repeatable: r
            }

    shortOption :: L.TokenParser Argument
    shortOption = OptionStack <$> do
      { flag, stack, arg } <- L.sopt
      r <- repetition
      pure  { flag:       flag
            , stack:      stack
            , arg:        arg
            , repeatable: r
            }

    option :: L.TokenParser Argument
    option = longOption <|> shortOption

    reference :: L.TokenParser Argument
    reference = Reference <$> L.reference

    positional :: L.TokenParser Argument
    positional = Positional <$> do
      name <- L.shoutName <|> L.angleName
      r    <- repetition
      pure { name: name, repeatable: r }

    command :: L.TokenParser Argument
    command = Command <$> do
      name <-  L.name
      r    <- repetition
      pure { name: name, repeatable: r }

    group :: L.TokenParser Argument
    group = defer \_ -> P.choice [ reqGroup , optGroup ]

    optGroup :: L.TokenParser Argument
    optGroup = defer \_ -> Group <$> do
      branches <- P.between
                    (indented *> L.lsquare)
                    (L.rsquare)
                    ((some elem) `P.sepBy1` L.vbar)
      r <- repetition
      pure { optional: true, branches: branches, repeatable: r }

    reqGroup :: L.TokenParser Argument
    reqGroup = defer \_ -> Group <$> do
      branches <- P.between
                    (indented *> L.lparen)
                    (L.rparen)
                    ((some elem) `P.sepBy1` L.vbar)
      r <- repetition
      pure { optional: false, branches: branches, repeatable: r }

    repetition :: L.TokenParser Boolean
    repetition = P.option false (indented *> L.tripleDot $> true)

    program :: L.TokenParser String
    program = "Program name" <??> L.name

parse :: Boolean                  -- ^ Enable "smart-options"
      -> (List L.PositionedToken) -- ^ The token stream
      -> Either P.ParseError (List Usage)
parse smartOpts = flip L.runTokenParser (usageParser smartOpts)

run :: String  -- ^ The usage section text
    -> Boolean -- ^ Enable "smart-options"
    -> Either P.ParseError (List Usage)
run x smartOpts = parse smartOpts =<< L.lexUsage x


Fix warnings

Fix warnings

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module Test.Main where

import Prelude (Unit, discard, (>=))

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Exception (EXCEPTION)

-- import Test.Unit (suite, test, TestF)
-- import Test.Unit.Console (TESTOUTPUT)
--
-- import Test.Unit.Main (runTest)
-- import Test.Unit.Assert as Assert

import Test.QuickCheck (quickCheck)

import Data.List (List)
import Main (length)

main :: forall e. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | e) Unit
main = mainQuickCheck

-- Using QuickCheck
mainQuickCheck :: forall e. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | e) Unit
mainQuickCheck = do
  quickCheck \(xs :: List Int) -> length xs >= 0
  quickCheck \(xs :: List Char) -> length xs >= 0
  quickCheck \(xs :: List String) -> length xs >= 0
  quickCheck \(xs :: List Boolean) -> length xs >= 0

-- Using Test.Unit
-- mainUnit :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR | e) Unit
-- mainUnit = runTest do
--   sumTest
--   lengthTest
--
-- sumTest :: forall e. Free (TestF e) Unit
-- sumTest = suite "sum" do
--   test "should be zero for empty list" do
--     Assert.assert "empty array should be 0" $ (sum Nil) == 0
--   test "should be the same value for a single element" do
--     Assert.assert "0 for [0]" $ (sum (0 : Nil)) == 0
--     Assert.assert "1 for [1]" $ (sum (1 : Nil)) == 1
--     Assert.assert "-210 for [-210]" $ (sum (-210 : Nil)) == -210
--     Assert.assert "93152 for [93152]" $ (sum (93152 : Nil)) == 93152
--   test "should sum up multiple values of variable length" do
--     Assert.assert "0 for [0, 0, 0, 0, 0]" $ (sum (0 : 0 : 0 : 0 : 0 : Nil)) == 0
--     Assert.assert "1 for [1, 2, 3, 4]" $ (sum (1 : 2 : 3 : 4 : Nil)) == 10
--     Assert.assert "77 for [6, 1, 15, 52, 3]" $ (sum (6 : 1 : 15 : 52 : 3 : Nil)) == 77
--
-- lengthTest :: forall e. Free (TestF e) Unit
-- lengthTest = suite "length" do
--   test "should be zero for empty list" do
--     Assert.assert "empty list should be 0" $ (length Nil) == 0
--   test "should be the same value for a single element" do
--     Assert.assert "1 for [0]" $ (length (0 : Nil)) == 1
--     Assert.assert "1 for [-123]" $ (length (-123 : Nil)) == 1
--     Assert.assert "1 for [[]]" $ (length ((Nil) : Nil)) == 1
--   test "should length up multiple values of variable length" do
--     Assert.assert "3 for [[1], [2], [3]]" $ (length ((1 : Nil) : (2 : Nil) : (3 : Nil) : Nil)) == 3
--     Assert.assert "3 for [[], [1], [2]]" $ (length ((Nil) : (1 : Nil) : (2 : Nil) : Nil)) == 3
--     Assert.assert "2 for [[1, 2], [3, 4]]" $ (length ((1 : 2 : Nil) : (3 : 4 : Nil) : Nil)) == 2
--

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Aff.AVar
import Control.Monad.Free (Free)

-- import Test.Unit (suite, test, TestF)
-- import Test.Unit.Console (TESTOUTPUT)
--
-- import Test.Unit.Main (runTest)
-- import Test.Unit.Assert as Assert

import Test.QuickCheck

import Data.List
import Data.Maybe
import Main (sum, length)

-- main :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR | e) Unit
main = mainQuickCheck

-- Using QuickCheck
mainQuickCheck = do
  quickCheck \(xs :: List Int) -> length xs >= 0
  quickCheck \(xs :: List Char) -> length xs >= 0
  quickCheck \(xs :: List String) -> length xs >= 0
  quickCheck \(xs :: List Boolean) -> length xs >= 0

-- Using Test.Unit
-- mainUnit :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR | e) Unit
-- mainUnit = runTest do
--   sumTest
--   lengthTest
--
-- sumTest :: forall e. Free (TestF e) Unit
-- sumTest = suite "sum" do
--   test "should be zero for empty list" do
--     Assert.assert "empty array should be 0" $ (sum Nil) == 0
--   test "should be the same value for a single element" do
--     Assert.assert "0 for [0]" $ (sum (0 : Nil)) == 0
--     Assert.assert "1 for [1]" $ (sum (1 : Nil)) == 1
--     Assert.assert "-210 for [-210]" $ (sum (-210 : Nil)) == -210
--     Assert.assert "93152 for [93152]" $ (sum (93152 : Nil)) == 93152
--   test "should sum up multiple values of variable length" do
--     Assert.assert "0 for [0, 0, 0, 0, 0]" $ (sum (0 : 0 : 0 : 0 : 0 : Nil)) == 0
--     Assert.assert "1 for [1, 2, 3, 4]" $ (sum (1 : 2 : 3 : 4 : Nil)) == 10
--     Assert.assert "77 for [6, 1, 15, 52, 3]" $ (sum (6 : 1 : 15 : 52 : 3 : Nil)) == 77
--
-- lengthTest :: forall e. Free (TestF e) Unit
-- lengthTest = suite "length" do
--   test "should be zero for empty list" do
--     Assert.assert "empty list should be 0" $ (length Nil) == 0
--   test "should be the same value for a single element" do
--     Assert.assert "1 for [0]" $ (length (0 : Nil)) == 1
--     Assert.assert "1 for [-123]" $ (length (-123 : Nil)) == 1
--     Assert.assert "1 for [[]]" $ (length ((Nil) : Nil)) == 1
--   test "should length up multiple values of variable length" do
--     Assert.assert "3 for [[1], [2], [3]]" $ (length ((1 : Nil) : (2 : Nil) : (3 : Nil) : Nil)) == 3
--     Assert.assert "3 for [[], [1], [2]]" $ (length ((Nil) : (1 : Nil) : (2 : Nil) : Nil)) == 3
--     Assert.assert "2 for [[1, 2], [3, 4]]" $ (length ((1 : 2 : Nil) : (3 : 4 : Nil) : Nil)) == 2
--


API change

API change

module Main where

import Prelude
import Control.Monad.Aff (runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (throwException)

import Halogen
import Halogen.Util (awaitBody)

import Network.HTTP.Affjax (AJAX())

import Model
import Component.Blog

main :: Eff (HalogenEffects (ajax :: AJAX)) Unit
main = runAff throwException (const (pure unit)) do
  body <- awaitBody
  runUI blog (parentState initialBlog) body

module Main where

import Prelude
import Control.Monad.Aff (runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (throwException)

import Halogen
import Halogen.Util (appendToBody, onLoad)

import Network.HTTP.Affjax (AJAX())

import Model
import Component.Blog

main :: Eff (HalogenEffects (ajax :: AJAX)) Unit
main = runAff throwException (const (pure unit)) do
  app <- runUI blog (installedState initialBlog)
  onLoad $ appendToBody app.node