split out render function

split out render function

module FrontEnd where

import Prelude
import Data.JSDate as JSDate
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Network.HTTP.Affjax as AJ
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Aff.Console (CONSOLE, errorShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.Monad.Except (runExcept)
import Control.MonadPlus (guard)
import DOM (DOM)
import Data.Array (filter, reverse, sort, sortWith)
import Data.Either (Either(Left), either)
import Data.Foreign (ForeignError)
import Data.Foreign.Class (class Encode, class Decode, encode)
import Data.Foreign.Generic (decodeJSON)
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(Nothing, Just), isJust, maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.String (Pattern(..), contains, toLower)
import Data.Traversable (find)
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V, invalid, unV)
import Global.Unsafe (unsafeStringify)
import Network.HTTP.Affjax (AJAX)
import Routes (Route(..), files, open, update, watched)
import Types (FileData(..), OpenRequest(..), Path(..), WatchedData(..))

type VE a = V (NonEmptyList ForeignError) a

request :: forall req res m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => Encode req
  => Decode res
  => Route req res -> Maybe req -> m (VE res)
request (Route route) body =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left route.method
      , url = route.url
      , content = unsafeStringify <<< encode <$> body
      }
    parseResponse response =
      runExcept $ decodeJSON response.response

unV' :: forall e a m.
  MonadAff
    ( console :: CONSOLE
    | e
    )
    m
  => (a -> m Unit) -> VE a -> m Unit
unV' = unV (H.liftAff <<< errorShow)

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = Title | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

type State =
  { files :: Array Path
  , watched :: Array WatchedData
  , sorting :: Sorting
  , search :: String
  }

data Query a
  = Init a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a

type AppEffects eff =
  Aff
  ( ajax :: AJAX
  , console :: CONSOLE
  | eff )

ui :: forall eff. H.Component HH.HTML Query Unit Void (AppEffects eff)
ui =
  H.lifecycleComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { files: mempty
      , watched: mempty
      , sorting: NoSorting
      , search: mempty
      }

    render :: State -> H.ComponentHTML Query
    render state =
      HH.div
        [ HP.class_ $ wrap "container" ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , search
          , header
          ] <> files
      where
        search =
          HH.div
            [ HP.class_ $ wrap "search" ]
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.h3
              [ HP.class_ $ wrap "file-link"
              , HE.onClick $ HE.input_ (ChangeSorting Title)
              ] [ HH.text $ "Title" <> displayTicker Title ]
            , HH.h3
              [ HP.class_ $ wrap "file-button"
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ wrap "file-note"] [ HH.text "Date" ]
            ]
        files =
          file <$> applyTransforms state.files

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms = applySorting <<< applyFiltering
        applyFiltering = case state.search of
            "" -> id
            x -> filter $ \(Path path) -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then id
            else reverse
          , sort' <- case col of
            Title -> sort
            Status -> sortWith findWatched
          = rev <<< sort'
          | otherwise = id
        findWatched path = find (\(WatchedData fd) -> fd.path == path) state.watched
        file path =
          HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.a
              [ HP.classes $ wrap <$>
                [ "file-link"
                , maybe "" (const "watched") watched
                ]
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.button
              [ HP.classes $ wrap <$>
                [ "file-button"
                , "pure-button"
                , maybe "" (const "pure-button-primary") watched
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watched))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watched ]
            , HH.span
              [ HP.class_ $ wrap "file-note" ]
              [ HH.text $ maybe "" id watched ]
            ]
          where
            watched = getDate <$> findWatched path
            getDate (WatchedData {created}) =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEff <<< JSDate.parse $ created

    eval :: Query ~> H.ComponentDSL State Query Void (AppEffects eff)
    eval (Init next) = do
      getResult >>= unV'
        \(Tuple f w) -> H.modify _ {files = f, watched = w}
      pure next
      where
        getResult = do
          files <- request files Nothing
          watched <- request watched Nothing
          pure $ Tuple <$> files <*> watched

    eval (OpenFile path next) = do
      _ <- request open $ Just (OpenRequest {path})
      pure next

    eval (SetWatched path flag next) = do
      request update (Just $ FileData {path, watched: flag}) >>= unV'
        \w -> H.modify _ {watched = w}
      pure next

    eval (Search str next) = do
      H.modify _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

main :: forall e.
  Eff
    ( avar :: AVAR
    , ref :: REF
    , exception :: EXCEPTION
    , dom :: DOM
    , console :: CONSOLE
    , ajax :: AJAX
    | e
    )
    Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log "Running"

module FrontEnd where

import Prelude
import Data.JSDate as JSDate
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Network.HTTP.Affjax as AJ
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Aff.Console (CONSOLE, errorShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import Data.Array (filter, reverse, sort, sortWith)
import Data.Either (Either(Left), either)
import Data.Foreign (ForeignError)
import Data.Foreign.Class (class Encode, class Decode, encode)
import Data.Foreign.Generic (decodeJSON)
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(Nothing, Just), isJust, maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.String (Pattern(..), contains, toLower)
import Data.Traversable (find)
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V, invalid, unV)
import Global.Unsafe (unsafeStringify)
import Network.HTTP.Affjax (AJAX)
import Routes (Route(..), files, open, update, watched)
import Types (FileData(..), OpenRequest(..), Path(..), WatchedData(..))

type VE a = V (NonEmptyList ForeignError) a

request :: forall req res m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => Encode req
  => Decode res
  => Route req res -> Maybe req -> m (VE res)
request (Route route) body =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left route.method
      , url = route.url
      , content = unsafeStringify <<< encode <$> body
      }
    parseResponse response =
      runExcept $ decodeJSON response.response

unV' :: forall e a m.
  MonadAff
    ( console :: CONSOLE
    | e
    )
    m
  => (a -> m Unit) -> VE a -> m Unit
unV' = unV (H.liftAff <<< errorShow)

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = Title | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

type State =
  { files :: Array Path
  , watched :: Array WatchedData
  , sorting :: Sorting
  , search :: String
  }

data Query a
  = Init a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a

type AppEffects eff =
  Aff
  ( ajax :: AJAX
  , console :: CONSOLE
  | eff )

ui :: forall eff. H.Component HH.HTML Query Unit Void (AppEffects eff)
ui =
  H.lifecycleComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { files: mempty
      , watched: mempty
      , sorting: NoSorting
      , search: mempty
      }

    render :: State -> H.ComponentHTML Query
    render state =
      HH.div
        [ HP.class_ $ wrap "container" ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , HH.div
            [ HP.class_ $ wrap "search" ]
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> if state.search == ""
                then mempty
                else pure $
                  HH.button
                    [ HE.onClick $ HE.input_ ClearSearch ]
                    [ HH.text "Clear" ]
          , HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.h3
              [ HP.class_ $ wrap "file-link"
              , HE.onClick $ HE.input_ (ChangeSorting Title)
              ] [ HH.text $ "Title" <> displayTicker Title ]
            , HH.h3
              [ HP.class_ $ wrap "file-button"
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ wrap "file-note"] [ HH.text "Date" ]
            ]
          ] <> (file <$> applyTransforms state.files)
      where
        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms = applySorting <<< applyFiltering
        applyFiltering = case state.search of
            "" -> id
            x -> filter $ \(Path path) -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC then id else reverse
          , sort' <- case col of
            Title -> sort
            Status -> sortWith findWatched
          = rev <<< sort'
          | otherwise = id
        findWatched path = find (\(WatchedData fd) -> fd.path == path) state.watched
        file path =
          HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.a
              [ HP.classes $ wrap <$>
                [ "file-link"
                , maybe "" (const "watched") watched
                ]
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.button
              [ HP.classes $ wrap <$>
                [ "file-button"
                , "pure-button"
                , maybe "" (const "pure-button-primary") watched
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watched))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watched ]
            , HH.span
              [ HP.class_ $ wrap "file-note" ]
              [ HH.text $ maybe "" id watched ]
            ]
          where
            watched = getDate <$> findWatched path
            getDate (WatchedData {created}) = JSDate.toDateString <<< unsafePerformEff <<< JSDate.parse $ created

    eval :: Query ~> H.ComponentDSL State Query Void (AppEffects eff)
    eval (Init next) = do
      getResult >>= unV'
        \(Tuple f w) -> H.modify _ {files = f, watched = w}
      pure next
      where
        getResult = do
          files <- request files Nothing
          watched <- request watched Nothing
          pure $ Tuple <$> files <*> watched

    eval (OpenFile path next) = do
      _ <- request open $ Just (OpenRequest {path})
      pure next

    eval (SetWatched path flag next) = do
      request update (Just $ FileData {path, watched: flag}) >>= unV'
        \w -> H.modify _ {watched = w}
      pure next

    eval (Search str next) = do
      H.modify _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

main :: forall e.
  Eff
    ( avar :: AVAR
    , ref :: REF
    , exception :: EXCEPTION
    , dom :: DOM
    , console :: CONSOLE
    , ajax :: AJAX
    | e
    )
    Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log "Running"


Use `Event` for `m` in `m Input`

Use `Event` for `m` in `m Input`

module View.File (I(), view) where

import Control.Alt ((<|>))
import Control.Alternative (Alternative)
import Control.Apply ((*>))
import Control.Functor (($>))
import Control.Inject1 (inj)
import Control.Monad.Aff
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Plus (empty)
import Controller.File
import Data.Array ((..), length, zipWith)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Input.File.Item (ItemInput(..))
import Model.Breadcrumb
import Model.File
import Model.Item
import Model.Path
import Model.Resource
import Model.Sort
import Utils.Halide (targetLink', readonly)
import View.File.Modal
import EffectTypes
import qualified Data.StrMap as SM
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified Utils as U
import qualified View.Css as Vc

type I e = E.Event (FileAppEff e) Input

homeHash :: String
homeHash = "#?sort=asc&q=path%3A%2F&salt="

glyph :: forall p i. A.ClassName -> H.HTML p i
glyph g = H.i [ A.classes [B.glyphicon, g] ] []

icon :: forall p i. H.HTML p i
icon = H.div [ A.classes [ B.colXs1, Vc.navIcon ] ]
             [ H.a [ A.href homeHash
                   , A.classes [B.navbarBrand, Vc.logo]
                   ]
                   [ glyph B.glyphiconFolderOpen ]
             ]

logo :: forall p i. H.HTML p i
logo = H.div [ A.classes [ B.colXs3, Vc.navLogo ] ]
             [ H.a [ A.href Config.slamDataHome
                   , A.classes [B.navbarBrand, Vc.logo]
                   ]
                   [ H.img [A.src "img/logo.svg"]
                           []
                   ]
             ]

search :: forall p e. (Request -> I e) -> State -> H.HTML p (I e)
search handler state =
  H.div [ A.classes [B.colXs12, B.colSm8, Vc.search] ]
        [ H.form [ A.class_ B.navbarForm
                 , E.onSubmit (\_ -> pure $ handler $ SearchSubmit state.search state.path)
                 ]
                 [ H.div [ A.classes ([B.inputGroup, Vc.searchInput] <> if state.search.valid then mempty else [B.hasError])]
                         [ H.input [ A.classes [B.formControl]
                                   , A.value state.search.value
                                   , A.title state.search.value
                                   , E.onFocus (E.input_ $ inj $ Focus true)
                                   , E.onBlur (E.input_ $ inj $ Focus false)
                                   , E.onInput (\v -> pure $ handler $ SearchChange state.search v state.path)
                                   ]
                                   []
                         , H.span [ A.class_ (if state.search.focused then Vc.searchPathActive else Vc.searchPath) ]
                                  [ H.span [ A.class_ Vc.searchPathBody ]
                                           [ H.text state.search.nextValue ]
                                  , H.span [ A.class_ (if state.search.nextValue == "" then Vc.searchAffixEmpty else Vc.searchAffix) ]
                                           [ H.text $ "path:" <> state.path ]
                                  ]
                         , H.img [ E.onClick (\_ -> pure $ handler $ SearchClear (state.searching && state.search.loading) state.search)
                                 , A.class_ Vc.searchClear
                                 , (if state.search.loading then A.src "img/spin.svg" else A.src "img/remove.svg")
                                 ]
                                 []
                         , H.span [ A.class_ B.inputGroupBtn ]
                                  [ H.button [ A.classes [B.btn, B.btnDefault]
                                             , A.disabled (not state.search.valid)
                                             ]
                                             [ glyph B.glyphiconSearch ]
                                  ]
                         ]
                 ]
        ]

breadcrumbs :: forall p e. (Request -> I e) -> State -> H.HTML p (I e)
breadcrumbs handler state =
  H.ol [ A.classes [B.breadcrumb, B.colXs8] ]
       (breadcrumbView <$> state.breadcrumbs)
  where
  breadcrumbView :: Breadcrumb -> H.HTML p (I e)
  breadcrumbView b = H.li_ [ H.a (targetLink' $ handler $ Breadcrumb b)
                                 [ H.text b.name ]
                           ]

sorting :: forall p e. (Request -> I e) -> State -> H.HTML p (I e)
sorting handler state =
  H.div [ A.classes [B.colXs4, Vc.toolbarSort] ]
        [ H.a (targetLink' $ handler $ SetSort $ notSort state.sort)
              [ H.text "Name"
              , H.i [ chevron state
                    , A.style (A.styles $ SM.fromList [Tuple "margin-left" "10px"])
                    ]
                    []
              ]
        ]
  where
  chevron { sort: Asc  } = A.classes [B.glyphicon, B.glyphiconChevronUp]
  chevron { sort: Desc } = A.classes [B.glyphicon, B.glyphiconChevronDown]

toolbar :: forall p e. (Request -> I e) -> State -> H.HTML p (I e)
toolbar handler state =
  H.div [ A.classes [B.colXs4, Vc.toolbarMenu] ]
        [ H.ul [ A.classes [B.listInline, B.pullRight] ]
               if inRoot state then [mount] else [file, folder, mount, notebook]
        ]
  where
  file :: H.HTML p (I e)
  file = H.li_ [ H.a [ A.href "javascript:void(0);"
                     , E.onClick (\ev -> pure $ handler $ UploadFile ev.target state)
                     ]
                     [ H.i [ A.title "upload file"
                           , A.classes [B.btnLg, B.glyphicon, B.glyphiconFile]
                           ]
                           [ H.input [ A.class_ B.hidden
                                     , A.type_ "file"
                                     , E.onChange (\ev -> pure $ handler $ FileListChanged ev.target state)
                                     ]
                                     []
                           ]
                     ]
               ]

  folder :: H.HTML p (I e)
  folder = toolItem' CreateFolder "create folder" B.glyphiconFolderClose

  notebook :: H.HTML p (I e)
  notebook = toolItem' CreateNotebook "create notebook" B.glyphiconBook

  mount :: H.HTML p (I e)
  mount = toolItem' MountDatabase "mount database" B.glyphiconHdd

  toolItem' :: (State -> Request) -> String -> A.ClassName -> H.HTML p (I e)
  toolItem' f = toolItem [B.btnLg] state (handler <<< f)

  inRoot :: State -> Boolean
  inRoot state = state.path == "" || state.path == "/"

toolItem :: forall a p e. [A.ClassName] -> a -> (a -> I e) -> String -> A.ClassName -> H.HTML p (I e)
toolItem classes actionArg action title icon =
  H.li_ [ H.a (targetLink' $ action actionArg)
              [ H.i [ A.title title
                    , A.classes (classes ++ [B.glyphicon, icon])
                    ]
                    []
              ]
        ]

item :: forall p e. (Request -> I e) -> Boolean -> Number -> Item -> H.HTML p (I e)
item handler searching ix state =
  H.div [ A.classes ([B.listGroupItem] ++ if state.selected then [B.listGroupItemInfo] else mempty)
        , E.onMouseOver (E.input_ $ inj $ ItemHover ix true)
        , E.onClick (E.input_ $ inj $ ItemSelect ix true)
        , E.onDoubleClick (\_ -> pure $ handler $ Open state)
        ]
        [ H.div [ A.class_ B.row ]
                [ H.div [ A.classes [B.colSm9, Vc.itemContent] ]
                        [ H.a (targetLink' $ handler $ Open state)
                              [ H.span_ [ H.i [ iconClasses state ]
                                              []
                                        , H.text $ (if searching then decodeURIPath state.root else "") <> state.name
                                        ]
                              ]
                        ]
                , H.div [ A.classes [B.colSm3, Vc.itemToolbar] ]
                        [ H.ul [ A.classes ([B.listInline, B.pullRight] ++ if not $ state.hovered || state.selected then [B.hidden] else mempty)
                               , A.style $ A.styles $ SM.fromList [Tuple "margin-bottom" "0"]
                               ]
                               (showToolbar state)
                        ]
                ]
        ]
  where

  iconClasses :: Item -> A.Attr (I e)
  iconClasses state = A.classes [B.glyphicon, Vc.itemIcon, iconClass state.resource]

  iconClass :: Resource -> A.ClassName
  iconClass File      = B.glyphiconFile
  iconClass Database  = B.glyphiconHdd
  iconClass Notebook  = B.glyphiconBook
  iconClass Directory = B.glyphiconFolderOpen
  iconClass Table     = B.glyphiconTh

  showToolbar item | item.name == up = []
                   | otherwise =
    let conf = case item.resource of
          Database -> [ H.li_ [ H.a (targetLink' $ handler $ Configure item)
                                       [ H.i [ A.title "configure"
                                             , A.classes [B.glyphicon, B.glyphiconWrench]
                                             ]
                                             []
                                       ]
                                 ]
                         ]
          _ -> []
    in conf <> [ toolItem' Move "move/rename" B.glyphiconMove
               , toolItem' Delete "remove" B.glyphiconTrash
               , toolItem' Share "share" B.glyphiconShare
               ]
    where
    toolItem' :: (Item -> Request) -> String -> A.ClassName -> H.HTML p (I e)
    toolItem' f = toolItem [] item (handler <<< f)

items :: forall p e. (Request -> I e) -> State -> H.HTML p (I e)
items handler state =
  H.div [ A.classes [B.listGroup, Vc.results] ]
        $ zipWith (item handler state.searching) (0..length state.items) state.items

view :: forall p e. (Request -> I e) -> State -> H.HTML p (I e)
view handler state =
  H.div_ [ navbar [ H.div [ A.classes [Vc.navCont, B.containerFluid] ]
                          [ icon, logo, search handler state ]
                  ]
         , content [ H.div [ A.class_ B.clearfix ]
                           [ breadcrumbs handler state
                           , toolbar handler state
                           ]
                   , row [ sorting handler state ]
                   , items handler state
                   ]
         , modal state
         ]
  where

  contentClasses :: [A.ClassName]
  contentClasses = [B.colMd8, B.colMdOffset2, B.colSm10, B.colSmOffset1]

  content :: [H.HTML p (I e)] -> H.HTML p (I e)
  content nodes = H.div [ A.class_ B.container ]
                        [ row [ H.div [ A.classes contentClasses ]
                                      nodes
                              ]
                        ]

  row :: [H.HTML p (I e)] -> H.HTML p (I e)
  row = H.div [ A.class_ B.row ]

  navbar :: [H.HTML p (I e)] -> H.HTML p (I e)
  navbar = H.nav [ A.classes [B.navbar, B.navbarInverse, B.navbarFixedTop] ]

module View.File (view) where

import Control.Alt ((<|>))
import Control.Alternative (Alternative)
import Control.Apply ((*>))
import Control.Functor (($>))
import Control.Inject1 (inj)
import Control.Monad.Aff
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Plus (empty)
import Controller.File
import Data.Array ((..), length, zipWith)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Input.File.Item (ItemInput(..))
import Model.Breadcrumb
import Model.File
import Model.Item
import Model.Path
import Model.Resource
import Model.Sort
import Utils.Halide (targetLink', readonly)
import View.File.Modal
import qualified Data.StrMap as SM
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified Utils as U
import qualified View.Css as Vc

homeHash :: String
homeHash = "#?sort=asc&q=path%3A%2F&salt="

glyph :: forall p i. A.ClassName -> H.HTML p i
glyph g = H.i [ A.classes [B.glyphicon, g] ] []

icon :: forall p i. H.HTML p i
icon = H.div [ A.classes [ B.colXs1, Vc.navIcon ] ]
             [ H.a [ A.href homeHash
                   , A.classes [B.navbarBrand, Vc.logo]
                   ]
                   [ glyph B.glyphiconFolderOpen ]
             ]

logo :: forall p i. H.HTML p i
logo = H.div [ A.classes [ B.colXs3, Vc.navLogo ] ]
             [ H.a [ A.href Config.slamDataHome
                   , A.classes [B.navbarBrand, Vc.logo]
                   ]
                   [ H.img [A.src "img/logo.svg"]
                           []
                   ]
             ]

search :: forall p m. (Alternative m) => (Request -> m Input) -> State -> H.HTML p (m Input)
search handler state =
  H.div [ A.classes [B.colXs12, B.colSm8, Vc.search] ]
        [ H.form [ A.class_ B.navbarForm
                 , E.onSubmit (\_ -> pure $ handler $ SearchSubmit state.search state.path)
                 ]
                 [ H.div [ A.classes ([B.inputGroup, Vc.searchInput] <> if state.search.valid then mempty else [B.hasError])]
                         [ H.input [ A.classes [B.formControl]
                                   , A.value state.search.value
                                   , A.title state.search.value
                                   , E.onFocus (E.input_ $ inj $ Focus true)
                                   , E.onBlur (E.input_ $ inj $ Focus false)
                                   , E.onInput (\v -> pure $ handler $ SearchChange state.search v state.path)
                                   ]
                                   []
                         , H.span [ A.class_ (if state.search.focused then Vc.searchPathActive else Vc.searchPath) ]
                                  [ H.span [ A.class_ Vc.searchPathBody ]
                                           [ H.text state.search.nextValue ]
                                  , H.span [ A.class_ (if state.search.nextValue == "" then Vc.searchAffixEmpty else Vc.searchAffix) ]
                                           [ H.text $ "path:" <> state.path ]
                                  ]
                         , H.img [ E.onClick (\_ -> pure $ handler $ SearchClear (state.searching && state.search.loading) state.search)
                                 , A.class_ Vc.searchClear
                                 , (if state.search.loading then A.src "img/spin.svg" else A.src "img/remove.svg")
                                 ]
                                 []
                         , H.span [ A.class_ B.inputGroupBtn ]
                                  [ H.button [ A.classes [B.btn, B.btnDefault]
                                             , A.disabled (not state.search.valid)
                                             ]
                                             [ glyph B.glyphiconSearch ]
                                  ]
                         ]
                 ]
        ]

breadcrumbs :: forall p m. (Alternative m) => (Request -> m Input) -> State -> H.HTML p (m Input)
breadcrumbs handler state =
  H.ol [ A.classes [B.breadcrumb, B.colXs8] ]
       (breadcrumbView <$> state.breadcrumbs)
  where
  breadcrumbView :: Breadcrumb -> H.HTML p (m Input)
  breadcrumbView b = H.li_ [ H.a (targetLink' $ handler $ Breadcrumb b)
                                 [ H.text b.name ]
                           ]

sorting :: forall p. (Request -> E.Event _ Input) -> State -> H.HTML p (E.Event _ Input)
sorting handler state =
  H.div [ A.classes [B.colXs4, Vc.toolbarSort] ]
        [ H.a (targetLink' $ handler $ SetSort $ notSort state.sort)
              [ H.text "Name"
              , H.i [ chevron state
                    , A.style (A.styles $ SM.fromList [Tuple "margin-left" "10px"])
                    ]
                    []
              ]
        ]
  where
  chevron { sort: Asc  } = A.classes [B.glyphicon, B.glyphiconChevronUp]
  chevron { sort: Desc } = A.classes [B.glyphicon, B.glyphiconChevronDown]

toolbar :: forall p m. (Alternative m) => (Request -> m Input) -> State -> H.HTML p (m Input)
toolbar handler state =
  H.div [ A.classes [B.colXs4, Vc.toolbarMenu] ]
        [ H.ul [ A.classes [B.listInline, B.pullRight] ]
               if inRoot state then [mount] else [file, folder, mount, notebook]
        ]
  where
  file :: H.HTML p (m Input)
  file = H.li_ [ H.a [ A.href "javascript:void(0);"
                     , E.onClick (\ev -> pure $ handler $ UploadFile ev.target state)
                     ]
                     [ H.i [ A.title "upload file"
                           , A.classes [B.btnLg, B.glyphicon, B.glyphiconFile]
                           ]
                           [ H.input [ A.class_ B.hidden
                                     , A.type_ "file"
                                     , E.onChange (\ev -> pure $ handler $ FileListChanged ev.target state)
                                     ]
                                     []
                           ]
                     ]
               ]

  folder :: H.HTML p (m Input)
  folder = toolItem' CreateFolder "create folder" B.glyphiconFolderClose

  notebook :: H.HTML p (m Input)
  notebook = toolItem' CreateNotebook "create notebook" B.glyphiconBook

  mount :: H.HTML p (m Input)
  mount = toolItem' MountDatabase "mount database" B.glyphiconHdd

  toolItem' :: (State -> Request) -> String -> A.ClassName -> H.HTML p (m Input)
  toolItem' f = toolItem [B.btnLg] state (handler <<< f)

  inRoot :: State -> Boolean
  inRoot state = state.path == "" || state.path == "/"

toolItem :: forall a p m. (Alternative m) => [A.ClassName] -> a -> (a -> m Input) -> String -> A.ClassName -> H.HTML p (m Input)
toolItem classes actionArg action title icon =
  H.li_ [ H.a (targetLink' $ action actionArg)
              [ H.i [ A.title title
                    , A.classes (classes ++ [B.glyphicon, icon])
                    ]
                    []
              ]
        ]

item :: forall p m. (Alternative m) => (Request -> m Input) -> Boolean -> Number -> Item -> H.HTML p (m Input)
item handler searching ix state =
  H.div [ A.classes ([B.listGroupItem] ++ if state.selected then [B.listGroupItemInfo] else mempty)
        , E.onMouseOver (E.input_ $ inj $ ItemHover ix true)
        , E.onClick (E.input_ $ inj $ ItemSelect ix true)
        , E.onDoubleClick (\_ -> pure $ handler $ Open state)
        ]
        [ H.div [ A.class_ B.row ]
                [ H.div [ A.classes [B.colSm9, Vc.itemContent] ]
                        [ H.a (targetLink' $ handler $ Open state)
                              [ H.span_ [ H.i [ iconClasses state ]
                                              []
                                        , H.text $ (if searching then decodeURIPath state.root else "") <> state.name
                                        ]
                              ]
                        ]
                , H.div [ A.classes [B.colSm3, Vc.itemToolbar] ]
                        [ H.ul [ A.classes ([B.listInline, B.pullRight] ++ if not $ state.hovered || state.selected then [B.hidden] else mempty)
                               , A.style $ A.styles $ SM.fromList [Tuple "margin-bottom" "0"]
                               ]
                               (showToolbar state)
                        ]
                ]
        ]
  where

  iconClasses :: Item -> A.Attr (m Input)
  iconClasses state = A.classes [B.glyphicon, Vc.itemIcon, iconClass state.resource]

  iconClass :: Resource -> A.ClassName
  iconClass File      = B.glyphiconFile
  iconClass Database  = B.glyphiconHdd
  iconClass Notebook  = B.glyphiconBook
  iconClass Directory = B.glyphiconFolderOpen
  iconClass Table     = B.glyphiconTh

  showToolbar item | item.name == up = []
                   | otherwise =
    let conf = case item.resource of
          Database -> [ H.li_ [ H.a (targetLink' $ handler $ Configure item)
                                       [ H.i [ A.title "configure"
                                             , A.classes [B.glyphicon, B.glyphiconWrench]
                                             ]
                                             []
                                       ]
                                 ]
                         ]
          _ -> []
    in conf <> [ toolItem' Move "move/rename" B.glyphiconMove
               , toolItem' Delete "remove" B.glyphiconTrash
               , toolItem' Share "share" B.glyphiconShare
               ]
    where
    toolItem' :: (Item -> Request) -> String -> A.ClassName -> H.HTML p (m Input)
    toolItem' f = toolItem [] item (handler <<< f)

items :: forall p m. (Alternative m) => (Request -> m Input) -> State -> H.HTML p (m Input)
items handler state =
  H.div [ A.classes [B.listGroup, Vc.results] ]
        $ zipWith (item handler state.searching) (0..length state.items) state.items

view :: forall p e. (Request -> E.Event _ Input) -> State -> H.HTML p (E.Event _ Input)
view handler state =
  H.div_ [ navbar [ H.div [ A.classes [Vc.navCont, B.containerFluid] ]
                          [ icon, logo, search handler state ]
                  ]
         , content [ H.div [ A.class_ B.clearfix ]
                           [ breadcrumbs handler state
                           , toolbar handler state
                           ]
                   , row [ sorting handler state ]
                   , items handler state
                   ]
         , modal state
         ]
  where

  contentClasses :: [A.ClassName]
  contentClasses = [B.colMd8, B.colMdOffset2, B.colSm10, B.colSmOffset1]

  content :: forall m. (Alternative m) => [H.HTML p (m Input)] -> H.HTML p (m Input)
  content nodes = H.div [ A.class_ B.container ]
                        [ row [ H.div [ A.classes contentClasses ]
                                      nodes
                              ]
                        ]

  row :: forall m. (Alternative m) => [H.HTML p (m Input)] -> H.HTML p (m Input)
  row = H.div [ A.class_ B.row ]

  navbar :: forall m. (Alternative m) => [H.HTML p (m Input)] -> H.HTML p (m Input)
  navbar = H.nav [ A.classes [B.navbar, B.navbarInverse, B.navbarFixedTop] ]


Remove superfluous blank lines in TypeScript

module Language.TypeScript
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Either as Either
import Data.Foldable (any, for_, intercalate, maximum)
import Data.List (List)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.String (length, null, toCharArray) as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize, isLetterOrLetterNumber, legalizeCharacters, startWithLetter, stringEscape, times) as Str
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Renderer, blank, combineNames, forEachClass_, forEachTopLevel_, getModuleName, getSingleTopLevel, getTopLevels, indent, line, lookupClassName, lookupName, renderRenderItems, simpleNamer, transformPropertyNames)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, mapUnionM, nullableFromUnion)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { displayName: "TypeScript"
    , names: [ "typescript", "ts" ]
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert"] <> reservedWords
        , topLevelName: simpleNamer lowerNameStyle
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

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

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.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

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromUnion ur of
    Just x -> renderType x
    Nothing -> do
        types <- mapUnionM renderType ur
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion ur) ->
        case nullableFromUnion ur of
        Just x -> do
            rendered <- renderType x
            pure $ rendered <> "[]"
        Nothing -> do
            rendered <- renderUnion ur
            pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion ur -> renderUnion ur

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

legalize :: String -> String
legalize = Str.legalizeCharacters isPartCharacter

tsNameStyle :: Boolean -> String -> String
tsNameStyle upper = legalize >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = tsNameStyle true

lowerNameStyle :: String -> String
lowerNameStyle = tsNameStyle false

quote :: String -> String
quote s = "\"" <> s <> "\""

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = quote $ Str.stringEscape s
    | Str.null s = quote ""
    | any (not <<< isStartCharacter) (Str.toCharArray s) = quote $ Str.stringEscape s
    | otherwise =  Str.stringEscape s

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

typeMethodName :: String -> String -> Doc String
typeMethodName nameForSingle topLevelName = do
    single <- getSingleTopLevel
    pure $ maybe (topLevelName <> Str.capitalize nameForSingle) (const nameForSingle) single

deserializerName :: String -> Doc String
deserializerName = typeMethodName "fromJson"

serializerName :: String -> Doc String
serializerName = typeMethodName "toJson"

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topLevelTypes <- M.values <$> getTopLevels
    topMaybeClassNames :: List (Maybe String) <- mapM getContainedClassName topLevelTypes
    let maybeTopClassNames = mapM id topMaybeClassNames
    moduleName <- getModuleName upperNameStyle
    let imports =
            case maybeTopClassNames of
                Just names -> {
                    basic:    "{ " <> intercalate ", " names  <> " }",
                    advanced: "{ " <> intercalate ", " names  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> moduleName,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this data:
//
//   import """ <> imports.basic  <> """ from "./""" <> moduleName  <> ";"
    forEachTopLevel_ \topLevelName topLevelType -> do
        topFull <- renderType topLevelType
        line $ "//   let value: " <> topFull  <> " = JSON.parse(json);"
    line $ """//
// Or use Convert.fromJson to perform a type-checking conversion:
//
//   import """ <> imports.advanced  <> """ from "./""" <> moduleName  <> ";"
    forEachTopLevel_ \topLevelName topLevelType -> do
        topFull <- renderType topLevelType
        deserializer <- deserializerName topLevelName
        line $ "//   let value: " <> topFull  <> " = Convert." <> deserializer <> "(json);"
    line "//"
    blank
    renderRenderItems blank Nothing renderInterface Nothing
    blank
    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: String -> Map String IRType -> Doc Unit
renderInterface className properties = do
    let propertyNames = transformPropertyNames (simpleNamer propertyNamify) (_ <> "_") [] properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array (Tuple String IRType)
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromUnion unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNoInformation -> pure $ quote "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure $ quote "undefined"
    IRNull -> pure $ quote "undefined"
    IRInteger -> pure $ quote "number"
    IRDouble -> pure $ quote "number"
    IRBool -> pure $ quote "boolean"
    IRString -> pure $ quote "string"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object(" <> quote name <> ")"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapUnionM renderTypeMapType types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: String -> Map String IRType -> Doc Unit
renderTypeMapClass className properties = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array (Tuple String IRType)
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line $ "const typeMap: any = {"
    indent do
        forEachClass_ renderTypeMapClass
    line $ "};"

converter :: Doc Unit
converter = do
    line $ """export module Convert {
    let path: string[] = [];
"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        topFull <- renderType topLevelType
        topTypeMap <- renderTypeMapType topLevelType
        deserializer <- deserializerName topLevelName
        serializer <- serializerName topLevelName
        line $ """    export function """ <> deserializer <> """(json: string): """ <> topFull <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> topFull <> """): string {
        return JSON.stringify(value);
    }
"""
    line """    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == "undefined") return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`["${prop}"]`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line "}"

reservedWords :: Array String
reservedWords = ["break", "case", "catch", "class", "const", "continue", "debugger", "default", "delete", "do", "else", "enum", "export", "extends", "false", "finally", "for", "function", "if", "import", "in", "instanceof", "new", "null", "return", "super", "switch", "this", "throw", "true", "try", "typeof", "var", "void", "while", "with", "as", "implements", "interface", "let", "package", "private", "protected", "public", "static", "yield", "any", "boolean", "constructor", "declare", "get", "module", "require", "number", "set", "string", "symbol", "type", "from", "of"]

module Language.TypeScript
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Either as Either
import Data.Foldable (any, for_, intercalate, maximum)
import Data.List (List)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.String (length, null, toCharArray) as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize, isLetterOrLetterNumber, legalizeCharacters, startWithLetter, stringEscape, times) as Str
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Renderer, blank, combineNames, forEachClass_, forEachTopLevel_, getModuleName, getSingleTopLevel, getTopLevels, indent, line, lookupClassName, lookupName, renderRenderItems, simpleNamer, transformPropertyNames)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, mapUnionM, nullableFromUnion)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { displayName: "TypeScript"
    , names: [ "typescript", "ts" ]
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert"] <> reservedWords
        , topLevelName: simpleNamer lowerNameStyle
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

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

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.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

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromUnion ur of
    Just x -> renderType x
    Nothing -> do
        types <- mapUnionM renderType ur
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion ur) ->
        case nullableFromUnion ur of
        Just x -> do
            rendered <- renderType x
            pure $ rendered <> "[]"
        Nothing -> do
            rendered <- renderUnion ur
            pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion ur -> renderUnion ur

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

legalize :: String -> String
legalize = Str.legalizeCharacters isPartCharacter

tsNameStyle :: Boolean -> String -> String
tsNameStyle upper = legalize >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = tsNameStyle true

lowerNameStyle :: String -> String
lowerNameStyle = tsNameStyle false

quote :: String -> String
quote s = "\"" <> s <> "\""

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = quote $ Str.stringEscape s
    | Str.null s = quote ""
    | any (not <<< isStartCharacter) (Str.toCharArray s) = quote $ Str.stringEscape s
    | otherwise =  Str.stringEscape s

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

typeMethodName :: String -> String -> Doc String
typeMethodName nameForSingle topLevelName = do
    single <- getSingleTopLevel
    pure $ maybe (topLevelName <> Str.capitalize nameForSingle) (const nameForSingle) single

deserializerName :: String -> Doc String
deserializerName = typeMethodName "fromJson"

serializerName :: String -> Doc String
serializerName = typeMethodName "toJson"

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topLevelTypes <- M.values <$> getTopLevels
    topMaybeClassNames :: List (Maybe String) <- mapM getContainedClassName topLevelTypes
    let maybeTopClassNames = mapM id topMaybeClassNames
    moduleName <- getModuleName upperNameStyle
    let imports =
            case maybeTopClassNames of
                Just names -> {
                    basic:    "{ " <> intercalate ", " names  <> " }",
                    advanced: "{ " <> intercalate ", " names  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> moduleName,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this data:
//
//   import """ <> imports.basic  <> """ from "./""" <> moduleName  <> ";"
    forEachTopLevel_ \topLevelName topLevelType -> do
        topFull <- renderType topLevelType
        line $ "//   let value: " <> topFull  <> " = JSON.parse(json);"
    line $ """//
// Or use Convert.fromJson to perform a type-checking conversion:
//
//   import """ <> imports.advanced  <> """ from "./""" <> moduleName  <> ";"
    forEachTopLevel_ \topLevelName topLevelType -> do
        topFull <- renderType topLevelType
        deserializer <- deserializerName topLevelName
        line $ "//   let value: " <> topFull  <> " = Convert." <> deserializer <> "(json);"
    line "//"
    blank
    renderRenderItems blank Nothing renderInterface Nothing
    blank
    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: String -> Map String IRType -> Doc Unit
renderInterface className properties = do
    let propertyNames = transformPropertyNames (simpleNamer propertyNamify) (_ <> "_") [] properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array (Tuple String IRType)
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromUnion unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNoInformation -> pure $ quote "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure $ quote "undefined"
    IRNull -> pure $ quote "undefined"
    IRInteger -> pure $ quote "number"
    IRDouble -> pure $ quote "number"
    IRBool -> pure $ quote "boolean"
    IRString -> pure $ quote "string"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object(" <> quote name <> ")"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapUnionM renderTypeMapType types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: String -> Map String IRType -> Doc Unit
renderTypeMapClass className properties = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array (Tuple String IRType)
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line $ "const typeMap: any = {"
    indent do
        forEachClass_ renderTypeMapClass
    line $ "};"

converter :: Doc Unit
converter = do
    line $ """export module Convert {
    let path: string[] = [];
"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        topFull <- renderType topLevelType
        topTypeMap <- renderTypeMapType topLevelType
        deserializer <- deserializerName topLevelName
        serializer <- serializerName topLevelName
        line $ """    export function """ <> deserializer <> """(json: string): """ <> topFull <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> topFull <> """): string {
        return JSON.stringify(value);
    }
"""
    line """    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == "undefined") return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`["${prop}"]`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

reservedWords :: Array String
reservedWords = ["break", "case", "catch", "class", "const", "continue", "debugger", "default", "delete", "do", "else", "enum", "export", "extends", "false", "finally", "for", "function", "if", "import", "in", "instanceof", "new", "null", "return", "super", "switch", "this", "throw", "true", "try", "typeof", "var", "void", "while", "with", "as", "implements", "interface", "let", "package", "private", "protected", "public", "static", "yield", "any", "boolean", "constructor", "declare", "get", "module", "require", "number", "set", "string", "symbol", "type", "from", "of"]


Fix docs

Fix docs

module Control.Monad.ST.Internal where

import Prelude

import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Partial.Unsafe (unsafePartial)

-- | `ST` is concerned with _restricted_ mutation. Mutation is restricted to a
-- | _region_ of mutable references. This kind is inhabited by phantom types
-- | which represent regions in the type system.
foreign import kind Region

-- | The `ST` type constructor allows _local mutation_, i.e. mutation which
-- | does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `run` function can be used to run a computation in the `ST` monad.
foreign import data ST :: Region -> Type -> Type

foreign import map_ :: forall r a b. (a -> b) -> ST r a -> ST r b

foreign import pure_ :: forall r a. a -> ST r a

foreign import bind_ :: forall r a b. ST r a -> (a -> ST r b) -> ST r b

instance functorST :: Functor (ST r) where
  map = map_

instance applyST :: Apply (ST r) where
  apply = ap

instance applicativeST :: Applicative (ST r) where
  pure = pure_

instance bindST :: Bind (ST r) where
  bind = bind_

instance monadST :: Monad (ST r)

instance monadRecST :: MonadRec (ST r) where
  tailRecM f a = do
    r <- new =<< f a
    while (isLooping <$> read r) do
      read r >>= case _ of
        Loop a' -> do
          e <- f a'
          void (write e r)
        Done b -> pure unit
    fromDone <$> read r
    where
      fromDone :: forall a b. Step a b -> b
      fromDone = unsafePartial \(Done b) -> b

      isLooping = case _ of
        Loop _ -> true
        _ -> false

-- | Run an `ST` computation.
-- |
-- | Note: the type of `run` uses a rank-2 type to constrain the phantom
-- | type `r`, such that the computation must not leak any mutable references
-- | to the surrounding computation. It may cause problems to apply this
-- | function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
foreign import run :: forall a. (forall r. ST r a) -> a

-- | Loop while a condition is `true`.
-- |
-- | `while b m` is ST computation which runs the ST computation `b`. If its
-- | result is `true`, it runs the ST computation `m` and loops. If not, the
-- | computation ends.
foreign import while :: forall r a. ST r Boolean -> ST r a -> ST r Unit

-- | Loop over a consecutive collection of numbers
-- |
-- | `ST.for lo hi f` runs the computation returned by the function `f` for each
-- | of the inputs between `lo` (inclusive) and `hi` (exclusive).
foreign import for :: forall r a. Int -> Int -> (Int -> ST r a) -> ST r Unit

-- | Loop over an array of values.
-- |
-- | `ST.foreach xs f` runs the computation returned by the function `f` for each
-- | of the inputs `xs`.
foreign import foreach :: forall r a. Array a -> (a -> ST r Unit) -> ST r Unit

-- | The type `STRef r a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST r` effect.
foreign import data STRef :: Region -> Type -> Type

-- | Create a new mutable reference.
foreign import new :: forall a r. a -> ST r (STRef r a)

-- | Read the current value of a mutable reference.
foreign import read :: forall a r. STRef r a -> ST r a

-- | Update the value of a mutable reference by applying a function
-- | to the current value, computing a new state value for the reference and
-- | a return value.
foreign import modify' :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b

-- | Modify the value of a mutable reference by applying a function to the
-- | current value. The modified value is returned.
modify :: forall r a. (a -> a) -> STRef r a -> ST r a
modify f = modify' \s -> let s' = f s in { state: s', value: s' }

-- | Set the value of a mutable reference.
foreign import write :: forall a r. a -> STRef r a -> ST r a

module Control.Monad.ST.Internal where

import Prelude

import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Partial.Unsafe (unsafePartial)

-- | `ST` is concerned with _restricted_ mutation. Mutation is restricted to a
-- | _region_ of mutable references. This kind is inhabited by phantom types
-- | which represent regions in the type system.
foreign import kind Region

-- | The `ST` type constructor allows _local mutation_, i.e. mutation which
-- | does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `run` function can be used to run a computation in the `ST` monad.
foreign import data ST :: Region -> Type -> Type

foreign import map_ :: forall r a b. (a -> b) -> ST r a -> ST r b

foreign import pure_ :: forall r a. a -> ST r a

foreign import bind_ :: forall r a b. ST r a -> (a -> ST r b) -> ST r b

instance functorST :: Functor (ST r) where
  map = map_

instance applyST :: Apply (ST r) where
  apply = ap

instance applicativeST :: Applicative (ST r) where
  pure = pure_

instance bindST :: Bind (ST r) where
  bind = bind_

instance monadST :: Monad (ST r)

instance monadRecST :: MonadRec (ST r) where
  tailRecM f a = do
    r <- new =<< f a
    while (isLooping <$> read r) do
      read r >>= case _ of
        Loop a' -> do
          e <- f a'
          void (write e r)
        Done b -> pure unit
    fromDone <$> read r
    where
      fromDone :: forall a b. Step a b -> b
      fromDone = unsafePartial \(Done b) -> b

      isLooping = case _ of
        Loop _ -> true
        _ -> false

-- | Run an `ST` computation.
-- |
-- | Note: the type of `run` uses a rank-2 type to constrain the phantom
-- | type `h`, such that the computation must not leak any mutable references
-- | to the surrounding computation. It may cause problems to apply this
-- | function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
foreign import run :: forall a. (forall r. ST r a) -> a

-- | Loop while a condition is `true`.
-- |
-- | `while b m` is ST computation which runs the ST computation `b`. If its
-- | result is `true`, it runs the ST computation `m` and loops. If not, the
-- | computation ends.
foreign import while :: forall r a. ST r Boolean -> ST r a -> ST r Unit

-- | Loop over a consecutive collection of numbers
-- |
-- | `ST.for lo hi f` runs the computation returned by the function `f` for each
-- | of the inputs between `lo` (inclusive) and `hi` (exclusive).
foreign import for :: forall r a. Int -> Int -> (Int -> ST r a) -> ST r Unit

-- | Loop over an array of values.
-- |
-- | `ST.foreach xs f` runs the computation returned by the function `f` for each
-- | of the inputs `xs`.
foreign import foreach :: forall r a. Array a -> (a -> ST r Unit) -> ST r Unit

-- | The type `STRef r a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST r` effect.
foreign import data STRef :: Region -> Type -> Type

-- | Create a new mutable reference.
foreign import new :: forall a r. a -> ST r (STRef r a)

-- | Read the current value of a mutable reference.
foreign import read :: forall a r. STRef r a -> ST r a

-- | Update the value of a mutable reference by applying a function
-- | to the current value, computing a new state value for the reference and
-- | a return value.
foreign import modify' :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b

-- | Modify the value of a mutable reference by applying a function to the
-- | current value. The modified value is returned.
modify :: forall r a. (a -> a) -> STRef r a -> ST r a
modify f = modify' \s -> let s' = f s in { state: s', value: s' }

-- | Set the value of a mutable reference.
foreign import write :: forall a r. a -> STRef r a -> ST r a


Improve test suite labeling

Improve test suite labeling

module Test.Spec.SolverSpec (solverSpec) where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Control.Bind ((=<<))
import Control.Apply ((*>))
import Data.List (List(..), toList)
import Control.Plus (empty)
import Data.Foldable (intercalate, for_)
import Control.Monad.Eff.Exception (error, throwException)
import qualified Data.Array as A
import Data.Maybe (Maybe(..))

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runEitherEff)
import qualified Test.Support.Usage as U
import qualified Test.Support.Docopt as D

import Docopt
import Docopt.Spec.Solver (solve, SolveError(..))
import qualified Docopt.Spec.Parser.Usage as U
import qualified Docopt.Spec.Parser.Desc as D
import Docopt.Spec.Parser.Scanner (scan)
import Docopt.Spec.Parser.Lexer (lex)
import Text.Wrap (dedent)

newtype TestSuite = TestSuite { usages :: Array U.Usage
                              , cases  :: Array TestCase
                              }
newtype TestCase = TestCase { descs    :: Array D.Desc
                            , expected :: Either String (Array Application) }

test :: Array U.Usage -> Array TestCase -> TestSuite
test us cs = TestSuite { usages: us, cases: cs }

pass :: Array D.Desc -> Array Application -> TestCase
pass ds as = TestCase { descs: ds, expected: Right as }

fail :: Array D.Desc -> String -> TestCase
fail ds msg = TestCase { descs: ds, expected: Left msg }

usage :: Array (Array U.Argument) -> U.Usage
usage = U.usage "foo"

application :: Array (Array Argument) -> Application
application xss = Application $ toList $ (\xs -> Branch $ toList xs) <$> xss

solverSpec =
  describe "solver" do
    (flip traverseWithIndex_) (toList [
      test ([ usage [ [ U.co "foo" ] ] ])
        [ pass  ([])
                ([ application [ [ D.co "foo" ] ] ])
        ]
    , test ([ usage [ [ U.po "foo" true ] ] ])
        [ pass  ([])
                ([ application [ [ D.po "foo" true ] ] ])
        ]
    , test ([ usage [ [ U.lo "foo" Nothing true ] ] ])
        [ pass  ([])
                ([ application [
                    [ D.opt Nothing (Just "foo") Nothing true ]
                ] ])
        ]
    ]) runtest

  where

    runtest n (TestSuite { usages, cases }) = do
      describe ("Suite " ++ show (n + 1)) do
        (flip traverseWithIndex_) (toList cases)
          \j (TestCase { descs, expected }) -> do
            it ("case " ++ show (j + 1) ++ "/" ++ (show $ A.length cases)) do
              vliftEff do
                evaltest
                  (solve (toList usages) (toList descs))
                  (toList <$> expected)

    evaltest (Right output) (Right expected)
      = if output == (toList expected)
            then return unit
            else throwException $ error $
              "Unexpected output:\n" ++ show output

    evaltest (Right output) (Left _)
      = throwException $ error $
          "Missing exception! Got:\n" ++ show output

    evaltest (Left err) (Left expected)
      = if (show err) == expected
            then return unit
            else throwException $ error $
              "Unexpected error:\n" ++ show err

    evaltest (Left err) _ = throwException $ error $ show err

    traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b)
                                                        -> (List a)
                                                        -> m Unit
    traverseWithIndex_ f xs = go xs 0
        where go Nil _         = return unit
              go (Cons x xs) i = f i x *> go xs (i + 1)

module Test.Spec.SolverSpec (solverSpec) where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Control.Bind ((=<<))
import Control.Apply ((*>))
import Data.List (List(..), toList)
import Control.Plus (empty)
import Data.Foldable (intercalate, for_)
import Control.Monad.Eff.Exception (error, throwException)
import qualified Data.Array as A
import Data.Maybe (Maybe(..))

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runEitherEff)
import qualified Test.Support.Usage as U
import qualified Test.Support.Docopt as D

import Docopt
import Docopt.Spec.Solver (solve, SolveError(..))
import qualified Docopt.Spec.Parser.Usage as U
import qualified Docopt.Spec.Parser.Desc as D
import Docopt.Spec.Parser.Scanner (scan)
import Docopt.Spec.Parser.Lexer (lex)
import Text.Wrap (dedent)

newtype TestSuite = TestSuite { usages :: Array U.Usage
                              , cases  :: Array TestCase
                              }
newtype TestCase = TestCase { descs    :: Array D.Desc
                            , expected :: Either String (Array Application) }

test :: Array U.Usage -> Array TestCase -> TestSuite
test us cs = TestSuite { usages: us, cases: cs }

pass :: Array D.Desc -> Array Application -> TestCase
pass ds as = TestCase { descs: ds, expected: Right as }

fail :: Array D.Desc -> String -> TestCase
fail ds msg = TestCase { descs: ds, expected: Left msg }

usage :: Array (Array U.Argument) -> U.Usage
usage = U.usage "foo"

application :: Array (Array Argument) -> Application
application xss = Application $ toList $ (\xs -> Branch $ toList xs) <$> xss

solverSpec =
  describe "solver" do
    for_ [
      test ([ usage [ [ U.co "foo" ] ] ])
        [ pass  ([])
                ([ application [ [ D.co "foo" ] ] ])
        ]
    , test ([ usage [ [ U.po "foo" true ] ] ])
        [ pass  ([])
                ([ application [ [ D.po "foo" true ] ] ])
        ]
    , test ([ usage [ [ U.lo "foo" Nothing true ] ] ])
        [ pass  ([])
                ([ application [
                    [ D.opt Nothing (Just "foo") Nothing true ]
                ] ])
        ]
    ] runtest

  where

    runtest (TestSuite { usages, cases }) = do
      (flip traverseWithIndex_) (toList cases)
        \j (TestCase { descs, expected }) -> do
          it ("case " ++ show (j + 1) ++ "/" ++ (show $ A.length cases)) do
            vliftEff do
              evaltest
                (solve (toList usages) (toList descs))
                (toList <$> expected)

    evaltest (Right output) (Right expected)
      = if output == (toList expected)
            then return unit
            else throwException $ error $
              "Unexpected output:\n" ++ show output

    evaltest (Right output) (Left _)
      = throwException $ error $
          "Missing exception! Got:\n" ++ show output

    evaltest (Left err) (Left expected)
      = if (show err) == expected
            then return unit
            else throwException $ error $
              "Unexpected error:\n" ++ show err

    evaltest (Left err) _ = throwException $ error $ show err

    traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b)
                                                        -> (List a)
                                                        -> m Unit
    traverseWithIndex_ f xs = go xs 0
        where go Nil _         = return unit
              go (Cons x xs) i = f i x *> go xs (i + 1)


getReplacement

getReplacement

module IdePurescript.QuickFix where

import Prelude

import Data.String (null)
import Data.String.Regex (regex)
import Data.String.Regex.Flags (global, noFlags)
import IdePurescript.Regex (replace', test')

-- | Modify suggestion replacement text, removing extraneous newlines
getReplacement :: String -> String -> String
getReplacement replacement extraText =
  let trailingNewline = test' (regex "\n\\s+$" noFlags) replacement
      addNewline = trailingNewline && (not $ null extraText)
  in
      replace' (regex "\\s+\n" global) "\n" replacement

-- | Get a title which explains what applying a compiler suggestion will do
getTitle :: String -> String
getTitle code = case code of
  "UnusedImport"                -> "Remove import"
  "RedundantEmptyHidingImport"  -> "Remove import"
  "DuplicateImport"             -> "Remove import"
  "RedundantUnqualifiedImport"  -> "Remove import"
  "DeprecatedQualifiedSyntax"   -> "Remove qualified keyword"
  "ImplicitImport"              -> "Make import explicit"
  "UnusedExplicitImport"        -> "Remove unused references"
  _                             -> "Apply Suggestion"

-- | Determine whether an error code represents an unknown token (unknown identifier or missing import)
isUnknownToken :: String -> Boolean
isUnknownToken code = case code of
  "UnknownValue" -> true
  "UnknownType" -> true
  "UnknownDataConstructor" -> true
  "UnknownTypeConstructor" -> true
    -- In later compiler versions UnknownName covers all of the above
  "UnknownName" -> true
  _ -> false

module IdePurescript.QuickFix where

-- | Get a title which explains what applying a compiler suggestion will do
getTitle :: String -> String
getTitle code = case code of
  "UnusedImport"                -> "Remove import"
  "RedundantEmptyHidingImport"  -> "Remove import"
  "DuplicateImport"             -> "Remove import"
  "RedundantUnqualifiedImport"  -> "Remove import"
  "DeprecatedQualifiedSyntax"   -> "Remove qualified keyword"
  "ImplicitImport"              -> "Make import explicit"
  "UnusedExplicitImport"        -> "Remove unused references"
  _                             -> "Apply Suggestion"

-- | Determine whether an error code represents an unknown token (unknown identifier or missing import)
isUnknownToken :: String -> Boolean
isUnknownToken code = case code of
  "UnknownValue" -> true
  "UnknownType" -> true
  "UnknownDataConstructor" -> true
  "UnknownTypeConstructor" -> true
    -- In later compiler versions UnknownName covers all of the above
  "UnknownName" -> true
  _ -> false