Classes are similar if one is a subtype of the other

Original commit d3b437d95c680cf7e63e645f87eea245e874ab9b

module Main where

import IR
import Prelude
import Types

import CSharp (renderer)
import CSharp as CSharp
import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson, isString)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Either.Nested (in1)
import Data.Foldable (find, for_, all, any)
import Data.List (List(..), fromFoldable, length, nub, partition, (:))
import Data.List as L
import Data.List.Types (List(..))
import Data.Map (Map, lookup, mapWithKey, toUnfoldable)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set (Set, insert, member)
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Data.Tuple as Tuple
import Doc (Doc)
import Doc as Doc
import Swift as Swift

lookupOrDefault :: forall k v. Ord k => v -> k -> Map.Map k v -> v
lookupOrDefault default key m =
    case Map.lookup key m of
    Nothing -> default
    Just x -> x

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> v) -> v -> Map.Map k v -> Map.Map k v -> Map.Map k v
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ Map.keys m1) (S.fromFoldable $ Map.keys m2)
        valueFor k = (unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2))
        kvps = map (\k -> Tuple.Tuple k (valueFor k)) allKeys
    in
        Map.fromFoldable kvps

unifyClasses :: IRClassData -> IRClassData -> IRClassData
unifyClasses (IRClassData na pa) (IRClassData nb pb) =
    IRClassData na (unionWithDefault unifyTypesWithNull IRNothing pa pb)

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.difference s (S.delete x s) }
            Nothing -> { element: element, rest: s }

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

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

unifyMaybes :: Maybe IRType -> Maybe IRType -> IRType
unifyMaybes Nothing Nothing = IRNothing
unifyMaybes (Just a) Nothing = a
unifyMaybes Nothing (Just b) = b
unifyMaybes (Just a) (Just b) = unifyTypes a b

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

unifyUnion :: S.Set IRType -> S.Set IRType -> S.Set IRType
unifyUnion sa sb =
    let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray = setFromType $ unifyMaybes arrayA arrayB
        unifiedClasses = setFromType $ unifyMaybes classA classB
    in
        S.unions [sa, sb, unifiedArray, unifiedClasses]

unifyTypes :: IRType -> IRType -> IRType
unifyTypes IRNothing x = x
unifyTypes x IRNothing = x
unifyTypes (IRArray a) (IRArray b) = IRArray (unifyTypes a b)
unifyTypes (IRClass a) (IRClass b) = IRClass (unifyClasses a b)
unifyTypes (IRUnion a) (IRUnion b) = IRUnion (unifyUnion a b)
unifyTypes (IRUnion a) b = IRUnion (unifyUnion a (S.singleton b))
unifyTypes a (IRUnion b) = IRUnion (unifyUnion (S.singleton a) b)
unifyTypes a b = if a == b then a else IRUnion (S.fromFoldable [a, b])

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

unifyTypesWithNull :: IRType -> IRType -> IRType
unifyTypesWithNull IRNothing IRNothing = IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    (\arr -> let typeName = singular name
        in
            IRArray (L.foldl (\t j -> unifyTypes t (makeTypeFromJson typeName j)) IRNothing arr))
    fromJObject
    json
    where
        fromJObject obj = IRClass (IRClassData name (Map.fromFoldable $ StrMap.foldMap toProperty obj))
        toProperty name json = L.singleton $ Tuple.Tuple name (makeTypeFromJson name json)

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType = case _ of
    IRClass cls@(IRClassData _ properties) -> cls : L.concatMap gatherClassesFromType (Map.values properties)
    IRArray t -> gatherClassesFromType t
    IRUnion s -> L.concatMap gatherClassesFromType (L.fromFoldable s)
    _ -> empty

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

propertiesSimilar :: forall v. Eq v => Map.Map String v -> Map.Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = Map.size $ matchingProperties pa pb
        bInA = Map.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (Map.size pa) * 3) && (bInA * 4 >= (Map.size pb) * 3)

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

isSubtypeOf :: IRType -> IRType -> Boolean
isSubtypeOf IRNothing _ = true
isSubtypeOf (IRUnion sa) (IRUnion sb) =
    all (\ta -> any (isSubtypeOf ta) sb) sa
isSubtypeOf (IRArray a) (IRArray b) =
    isSubtypeOf a b
isSubtypeOf (IRClass (IRClassData _ ma)) (IRClass (IRClassData _ mb)) =
    propertiesAreSubset ma mb
isSubtypeOf a b = a == b

propertiesAreSubset :: Map.Map String IRType -> Map.Map String IRType -> Boolean
propertiesAreSubset ma mb =
    all isInB (Map.toUnfoldable ma :: List _)
    where
        isInB (Tuple n ta) =
            case Map.lookup n mb of
            Nothing -> false
            Just tb -> isSubtypeOf ta tb

similarClasses :: L.List IRClassData -> { classes :: S.Set IRClassData, replacements :: Map.Map IRClassData IRClassData }
similarClasses L.Nil = { classes: S.empty, replacements: Map.empty }
similarClasses (thisClass@(IRClassData name properties) : rest) =
    let { yes: similar, no: others } = L.partition isSimilar rest
        recursiveResult@{ classes, replacements } = similarClasses others
    in
        if L.length similar == 0 then
            recursiveResult
        else
            let unified = L.foldl unifyClasses thisClass similar
                newReplacements = Map.fromFoldable (map (\c -> Tuple.Tuple c unified) (thisClass : similar))
            in
                { classes: S.insert unified classes, replacements: Map.union replacements newReplacements  }
    where
        isSimilar (IRClassData _ p) =
            propertiesSimilar p properties ||
            propertiesAreSubset p properties ||
            propertiesAreSubset properties p

replaceClasses :: (Map.Map IRClassData IRClassData) -> IRType -> IRType
replaceClasses m t@(IRClass c@(IRClassData name properties)) =
    case Map.lookup c m of
    Nothing -> IRClass (IRClassData name (Map.mapWithKey (\n t -> replaceClasses m t) properties))
    Just replacement -> IRClass replacement
replaceClasses m (IRArray t) = IRArray (replaceClasses m t)
replaceClasses m (IRUnion s) = IRUnion (S.map (replaceClasses m) s)
replaceClasses _ t = t

replaceSimilarClasses :: IRType -> IRType
replaceSimilarClasses t =
    let { classes, replacements } = similarClasses (gatherClassesFromType t)
    in
        replaceClasses replacements t

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> replaceSimilarClasses
    <#> gatherClassesFromType
    <#> L.nub
    <#> CSharp.renderer.render
    <#> Doc.render

module Main where

import IR
import Prelude
import Types

import CSharp (renderer)
import CSharp as CSharp
import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson, isString)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Either.Nested (in1)
import Data.Foldable (find)
import Data.Foldable (for_)
import Data.List (List(..), fromFoldable, length, nub, partition, (:))
import Data.List as L
import Data.List.Types (List(..))
import Data.Map (Map, lookup, mapWithKey, toUnfoldable)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set (Set, insert)
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Data.Tuple as Tuple
import Doc (Doc)
import Doc as Doc
import Swift as Swift

lookupOrDefault :: forall k v. Ord k => v -> k -> Map.Map k v -> v
lookupOrDefault default key m =
    case Map.lookup key m of
    Nothing -> default
    Just x -> x

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> v) -> v -> Map.Map k v -> Map.Map k v -> Map.Map k v
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ Map.keys m1) (S.fromFoldable $ Map.keys m2)
        valueFor k = (unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2))
        kvps = map (\k -> Tuple.Tuple k (valueFor k)) allKeys
    in
        Map.fromFoldable kvps

unifyClasses :: IRClassData -> IRClassData -> IRClassData
unifyClasses (IRClassData na pa) (IRClassData nb pb) =
    IRClassData na (unionWithDefault unifyTypesWithNull IRNothing pa pb)

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.difference s (S.delete x s) }
            Nothing -> { element: element, rest: s }

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

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

unifyMaybes :: Maybe IRType -> Maybe IRType -> IRType
unifyMaybes Nothing Nothing = IRNothing
unifyMaybes (Just a) Nothing = a
unifyMaybes Nothing (Just b) = b
unifyMaybes (Just a) (Just b) = unifyTypes a b

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

unifyUnion :: S.Set IRType -> S.Set IRType -> S.Set IRType
unifyUnion sa sb =
    let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray = setFromType $ unifyMaybes arrayA arrayB
        unifiedClasses = setFromType $ unifyMaybes classA classB
    in
        S.unions [sa, sb, unifiedArray, unifiedClasses]

unifyTypes :: IRType -> IRType -> IRType
unifyTypes IRNothing x = x
unifyTypes x IRNothing = x
unifyTypes (IRArray a) (IRArray b) = IRArray (unifyTypes a b)
unifyTypes (IRClass a) (IRClass b) = IRClass (unifyClasses a b)
unifyTypes (IRUnion a) (IRUnion b) = IRUnion (unifyUnion a b)
unifyTypes (IRUnion a) b = IRUnion (unifyUnion a (S.singleton b))
unifyTypes a (IRUnion b) = IRUnion (unifyUnion (S.singleton a) b)
unifyTypes a b = if a == b then a else IRUnion (S.fromFoldable [a, b])

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

unifyTypesWithNull :: IRType -> IRType -> IRType
unifyTypesWithNull IRNothing IRNothing = IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    (\arr -> let typeName = singular name
        in
            IRArray (L.foldl (\t j -> unifyTypes t (makeTypeFromJson typeName j)) IRNothing arr))
    fromJObject
    json
    where
        fromJObject obj = IRClass (IRClassData name (Map.fromFoldable $ StrMap.foldMap toProperty obj))
        toProperty name json = L.singleton $ Tuple.Tuple name (makeTypeFromJson name json)

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType = case _ of
    IRClass cls@(IRClassData _ properties) -> cls : L.concatMap gatherClassesFromType (Map.values properties)
    IRArray t -> gatherClassesFromType t
    IRUnion s -> L.concatMap gatherClassesFromType (L.fromFoldable s)
    _ -> empty

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

propertiesSimilar :: forall v. Eq v => Map.Map String v -> Map.Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = Map.size $ matchingProperties pa pb
        bInA = Map.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (Map.size pa) * 3) && (bInA * 4 >= (Map.size pb) * 3)

similarClasses :: L.List IRClassData -> { classes :: S.Set IRClassData, replacements :: Map.Map IRClassData IRClassData }
similarClasses L.Nil = { classes: S.empty, replacements: Map.empty }
similarClasses (thisClass@(IRClassData name properties) : rest) =
    let { yes: similar, no: others } = L.partition isSimilar rest
        recursiveResult@{ classes, replacements } = similarClasses others
    in
        if L.length similar == 0 then
            recursiveResult
        else
            let unified = L.foldl unifyClasses thisClass similar
                newReplacements = Map.fromFoldable (map (\c -> Tuple.Tuple c unified) (thisClass : similar))
            in
                { classes: S.insert unified classes, replacements: Map.union replacements newReplacements  }
    where isSimilar (IRClassData _ p) = propertiesSimilar p properties

replaceClasses :: (Map.Map IRClassData IRClassData) -> IRType -> IRType
replaceClasses m t@(IRClass c@(IRClassData name properties)) =
    case Map.lookup c m of
    Nothing -> IRClass (IRClassData name (Map.mapWithKey (\n t -> replaceClasses m t) properties))
    Just replacement -> IRClass replacement
replaceClasses m (IRArray t) = IRArray (replaceClasses m t)
replaceClasses m (IRUnion s) = IRUnion (S.map (replaceClasses m) s)
replaceClasses _ t = t

replaceSimilarClasses :: IRType -> IRType
replaceSimilarClasses t =
    let { classes, replacements } = similarClasses (gatherClassesFromType t)
    in
        replaceClasses replacements t

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> replaceSimilarClasses
    <#> gatherClassesFromType
    <#> L.nub
    <#> CSharp.renderer.render
    <#> Doc.render


Finally got runExceptT works

Finally got runExceptT works

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Aff.Console (log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Eff
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Except (ExceptT(..), runExceptT)
import Control.Monad.Except.Trans (class MonadTrans)
import Control.Monad.Trans.Class (lift)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document) as DOM
import DOM.Node.NonElementParentNode (getElementById)
import DOM.Node.Types (ElementId(..), documentToNonElementParentNode)
import Data.Argonaut (class DecodeJson, Json, decodeJson)
import Data.Array ((..))
import Data.Either (either)
import Data.Maybe (Maybe(..))
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as Ajax
import React (ReactElement, createFactory)
import React as React
import React.DOM as R
import ReactDOM as RD
import Thermite as T

data Action = RootDidMount

type Story = { title :: String }

type State = { topStories :: Array Story
             , topStoryIds :: Array Int }

genFakeStory :: Int -> Story
genFakeStory idx = { title: "Fake Story Title " <> show idx }

initState :: State
initState = { topStories: map genFakeStory (1 .. 30)
            , topStoryIds: []
            }

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

parseOrThrow :: forall m a. MonadThrow Error m => DecodeJson a => Json -> m a
parseOrThrow json = either (throwError <<< error) pure $ decodeJson json

performAction :: forall eff props.
                 T.PerformAction (ajax :: AJAX, console :: CONSOLE | eff) State props Action
performAction RootDidMount props state = do
  result <- runExceptT do
    liftAff $ log "Fetching Top Stories..."
    res <- liftAff $ Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"

    liftAff $ log "Parsing Json..."
    -- demo of error throw catch
    -- _ <- throwError $ error "test error"
    ids <- liftAff $ parseOrThrow res.response

    liftAff $ log "Update State..."
    r <- lift $ T.modifyState \s -> s { topStoryIds = ids }

    liftAff $ log "Done!"
    pure r

  either
    (\e -> lift $ log $ "Caught error: \n" <> show e)
    (\r -> pure unit)
    result

  where
    liftAff :: forall eff1 m a
             . MonadTrans m
            => Aff eff1 a
            -> ExceptT Error (m (Aff eff1)) a
    liftAff = ExceptT <<< lift <<< attempt

  -- eitherIds <- lift $ attempt $ do
  --   res <- Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"
  --   parseOrThrow res.response
  -- case eitherIds of
  --   Right ids -> void $ T.modifyState \s -> s { topStoryIds = ids }
  --   Left error -> lift $ logShow error

render :: forall eff. T.Render State eff Action
render dispatch _ state _ =
  [ R.p' [ R.text "Hello thermite!!" ]
  , R.div' $ renderStoryList <<< map genFakeStory $ state.topStoryIds
  ]

spec :: forall eff. T.Spec (ajax :: AJAX, console :: CONSOLE | eff) State Unit Action
spec = T.simpleSpec performAction render

type ReactSpec props state eff =
  { spec :: React.ReactSpec props state eff
  , dispatcher :: React.ReactThis props state -> Action -> T.EventHandler
  }

withComponentDidMount :: forall props state eff
                       . ReactSpec props state eff
                      -> ReactSpec props state eff
withComponentDidMount rs = rs { spec = specWithMount }
  where
    specWithMount = rs.spec { componentDidMount = handleDidMount }
    handleDidMount this = rs.dispatcher this RootDidMount

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  htmlDocument <- DOM.window >>= DOM.document
  let document = htmlDocumentToDocument htmlDocument
  maybeContainer <- getElementById (ElementId "app") $ documentToNonElementParentNode document
  case maybeContainer of
    Just container -> do
      let
        -- TODO the purescript react seems missing the type annotation for extensible effects
        reactSpec = T.createReactSpec spec initState
        component = React.createClass <<< _.spec $ withComponentDidMount reactSpec
        reactElement = createFactory component unit
      void $ RD.render reactElement container
    Nothing -> Eff.log "container #app not found"

module Main where

import Prelude

import Control.Monad.Aff (attempt)
import Control.Monad.Aff.Console (logShow)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Eff
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Trans.Class (lift)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document) as DOM
import DOM.Node.NonElementParentNode (getElementById)
import DOM.Node.Types (ElementId(..), documentToNonElementParentNode)
import Data.Argonaut (class DecodeJson, Json, decodeJson)
import Data.Array ((..))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..))
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as Ajax
import React (ReactElement, createFactory)
import React as React
import React.DOM as R
import ReactDOM as RD
import Thermite as T

data Action = RootDidMount

type Story = { title :: String }

type State = { topStories :: Array Story
             , topStoryIds :: Array Int }

genFakeStory :: Int -> Story
genFakeStory idx = { title: "Fake Story Title " <> show idx }

initState :: State
initState = { topStories: map genFakeStory (1 .. 30)
            , topStoryIds: []
            }

renderStoryItem :: Story -> ReactElement
renderStoryItem { title } = R.div' [ R.text title ]

renderStoryList :: Array Story -> Array ReactElement
renderStoryList = map renderStoryItem

parseOrThrow :: forall m a. MonadThrow Error m => DecodeJson a => Json -> m a
parseOrThrow json = either (throwError <<< error) pure $ decodeJson json

performAction :: forall eff props.
                 T.PerformAction (ajax :: AJAX, console :: CONSOLE | eff) State props Action
performAction RootDidMount props state = do
  eitherIds <- lift $ attempt $ do
    res <- Ajax.get "https://hacker-news.firebaseio.com/v0/topstories.json"
    parseOrThrow res.response
  case eitherIds of
    Right ids -> void $ T.modifyState \s -> s { topStoryIds = ids }
    Left error -> lift $ logShow error

render :: forall eff. T.Render State eff Action
render dispatch _ state _ =
  [ R.p' [ R.text "Hello thermite!!" ]
  , R.div' $ renderStoryList <<< map genFakeStory $ state.topStoryIds
  ]

spec :: forall eff. T.Spec (ajax :: AJAX, console :: CONSOLE | eff) State Unit Action
spec = T.simpleSpec performAction render

type ReactSpec props state eff =
  { spec :: React.ReactSpec props state eff
  , dispatcher :: React.ReactThis props state -> Action -> T.EventHandler
  }

withComponentDidMount :: forall props state eff
                       . ReactSpec props state eff
                      -> ReactSpec props state eff
withComponentDidMount rs = rs { spec = specWithMount }
  where
    specWithMount = rs.spec { componentDidMount = handleDidMount }
    handleDidMount this = rs.dispatcher this RootDidMount

main :: forall e. Eff (console :: CONSOLE, dom :: DOM | e) Unit
main = do
  htmlDocument <- DOM.window >>= DOM.document
  let document = htmlDocumentToDocument htmlDocument
  maybeContainer <- getElementById (ElementId "app") $ documentToNonElementParentNode document
  case maybeContainer of
    Just container -> do
      let
        -- TODO the purescript react seems missing the type annotation for extensible effects
        reactSpec = T.createReactSpec spec initState
        component = React.createClass <<< _.spec $ withComponentDidMount reactSpec
        reactElement = createFactory component unit
      void $ RD.render reactElement container
    Nothing -> Eff.log "container #app not found"


Some easy simplifications

Some easy simplifications

Original commit 4b13042370493e251d04961542224afcfd1acbf2

module Main where

import Prelude

import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concatMap, foldMap, (!!), (:))
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, foldMap, fromFoldable, toUnfoldable, values) as StrMap
import Data.Tuple (Tuple(Tuple))
import Partial.Unsafe (unsafePartial)

type IRClassData = { name :: String, properties :: StrMap.StrMap IRType }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    (case _ of
        [] -> IRArray IRNothing
        a ->
            let elementType = makeTypeFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            IRArray elementType)
    (\o -> IRClass { name, properties: mapProperties o })
    json

mapProperties :: StrMap.StrMap Json -> StrMap.StrMap IRType
mapProperties sm = StrMap.fromFoldable results
  where mapper (Tuple n j) = Tuple n (makeTypeFromJson n j)
        results = map mapper (unfold sm)

singularize :: String -> String
singularize s = "OneOf" <> s

-- This is a travesty.  Try putting this function definition
-- in the where clause below.
unfold :: forall a. StrMap.StrMap a -> Array (Tuple String a)
unfold sm = StrMap.toUnfoldable sm

gatherClassesFromType :: IRType -> Array IRClassData
gatherClassesFromType (IRClass classData) =
    let { name, properties } = classData in
    classData : (concatMap gatherClassesFromType (StrMap.values properties))
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = []

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = (renderTypeToCSharp a) <> "[]"
renderTypeToCSharp (IRClass { name }) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> String
renderClassToCSharp { name, properties } =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name irType = "    public " <> (renderTypeToCSharp irType) <> " " <> name <> " { get; set; }"

renderClassesToCSharp :: Array IRClassData -> String
renderClassesToCSharp classes =
    foldMap (\c -> (renderClassToCSharp c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as C
import Data.Argonaut.Core (JArray, JBoolean, JNull, JString, Json, JObject, foldJson, foldJsonObject)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (length, toUnfoldable, (:), concat, (!!), foldMap, concatMap)
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, fromFoldable, keys, values, foldMap, toUnfoldable) as StrMap
import Data.Tuple (uncurry, Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

data IRClassData = IRClassData { name :: String, properties :: StrMap.StrMap IRType }
data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const $ IRNull)
    (\b -> IRBool)
    (\x -> IRDouble)
    (\s -> IRString)
    (case _ of
        [] -> IRArray IRNothing
        a ->
            let elementType = makeTypeFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            IRArray elementType)
    (\o ->
        let props = mapProperties o in
        IRClass (IRClassData { name: name, properties: props }))
    json

mapProperties :: StrMap.StrMap Json -> StrMap.StrMap IRType
mapProperties sm = StrMap.fromFoldable results
  where mapper (Tuple n j) = Tuple n (makeTypeFromJson n j)
        results = map mapper (unfold sm)

singularize :: String -> String
singularize s = "OneOf" <> s

-- This is a travesty.  Try putting this function definition
-- in the where clause below.
unfold :: forall a. StrMap.StrMap a -> Array (Tuple String a)
unfold sm = StrMap.toUnfoldable sm

gatherClassesFromType :: IRType -> Array IRClassData
gatherClassesFromType (IRClass classData) =
    let IRClassData { name, properties } = classData in
    classData : (concatMap gatherClassesFromType (StrMap.values properties))
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = []

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = (renderTypeToCSharp a) <> "[]"
renderTypeToCSharp (IRClass (IRClassData { name, properties })) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> String
renderClassToCSharp (IRClassData { name, properties }) =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name irType = "    public " <> (renderTypeToCSharp irType) <> " " <> name <> " { get; set; }"

renderClassesToCSharp :: Array IRClassData -> String
renderClassesToCSharp classes =
    foldMap (\c -> (renderClassToCSharp c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp


Add 'mapThunk' for a combined hoist/map

Add 'mapThunk' for a combined hoist/map

module Halogen.VDom.Thunk
  ( Thunk
  , buildThunk
  , runThunk
  , hoist
  , mapThunk
  , thunked
  , thunk1
  , thunk2
  , thunk3
  ) where

import Prelude

import Data.Function.Uncurried as Fn
import Effect.Uncurried as EFn
import Halogen.VDom as V
import Halogen.VDom.Machine as M
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Node (Node)

foreign import data ThunkArg ∷ Type

foreign import data ThunkId ∷ Type

data Thunk f i = Thunk ThunkId (Fn.Fn2 ThunkArg ThunkArg Boolean) (ThunkArg → f i) ThunkArg

unsafeThunkId ∷ ∀ a. a → ThunkId
unsafeThunkId = unsafeCoerce

instance functorThunk ∷ Functor f ⇒ Functor (Thunk f) where
  map f (Thunk a b c d) = Thunk a b (c >>> map f) d

hoist ∷ ∀ f g. (f ~> g) → Thunk f ~> Thunk g
hoist = mapThunk

mapThunk ∷ ∀ f g i j. (f i -> g j) → Thunk f i -> Thunk g j
mapThunk k (Thunk a b c d) = Thunk a b (c >>> k) d

thunk ∷ ∀ a f i. Fn.Fn4 ThunkId (Fn.Fn2 a a Boolean) (a → f i) a (Thunk f i)
thunk = Fn.mkFn4 \tid eqFn f a →
  Thunk tid
    (unsafeCoerce eqFn ∷ Fn.Fn2 ThunkArg ThunkArg Boolean)
    (unsafeCoerce f ∷ ThunkArg → f i)
    (unsafeCoerce a ∷ ThunkArg)

thunked ∷ ∀ a f i. (a → a → Boolean) → (a → f i) → a → Thunk f i
thunked eqFn f =
  let
    tid = unsafeThunkId { f }
    eqFn' = Fn.mkFn2 eqFn
  in
    \a → Fn.runFn4 thunk tid eqFn' f a

thunk1 ∷ ∀ a f i. Fn.Fn2 (a → f i) a (Thunk f i)
thunk1 = Fn.mkFn2 \f a → Fn.runFn4 thunk (unsafeThunkId f) Util.refEq f a

thunk2 ∷ ∀ a b f i. Fn.Fn3 (a → b → f i) a b (Thunk f i)
thunk2 =
  let
    eqFn = Fn.mkFn2 \a b →
      Fn.runFn2 Util.refEq a._1 b._1 &&
      Fn.runFn2 Util.refEq a._2 b._2
  in
    Fn.mkFn3 \f a b →
      Fn.runFn4 thunk (unsafeThunkId f) eqFn (\{ _1, _2 } → f _1 _2) { _1: a, _2: b }

thunk3 ∷ ∀ a b c f i. Fn.Fn4 (a → b → c → f i) a b c (Thunk f i)
thunk3 =
  let
    eqFn = Fn.mkFn2 \a b →
      Fn.runFn2 Util.refEq a._1 b._1 &&
      Fn.runFn2 Util.refEq a._2 b._2 &&
      Fn.runFn2 Util.refEq a._3 b._3
  in
    Fn.mkFn4 \f a b c →
      Fn.runFn4 thunk (unsafeThunkId f) eqFn (\{ _1, _2, _3 } → f _1 _2 _3) { _1: a, _2: b, _3: c }

runThunk ∷ ∀ f i. Thunk f i → f i
runThunk (Thunk _ _ render arg) = render arg

unsafeEqThunk ∷ ∀ f i. Fn.Fn2 (Thunk f i) (Thunk f i) Boolean
unsafeEqThunk = Fn.mkFn2 \(Thunk a1 b1 _ d1) (Thunk a2 b2 _ d2) →
  Fn.runFn2 Util.refEq a1 a2 &&
  Fn.runFn2 Util.refEq b1 b2 &&
  Fn.runFn2 Util.refEq d1 d2

type ThunkState f i a w =
  { thunk ∷ Thunk f i
  , vdom ∷ M.Step (V.VDom a w) Node
  }

buildThunk
  ∷ ∀ f i a w
  . (f i → V.VDom a w)
  → V.VDomSpec a w
  → V.Machine (Thunk f i) Node
buildThunk toVDom = renderThunk
  where
  renderThunk ∷ V.VDomSpec a w → V.Machine (Thunk f i) Node
  renderThunk spec = EFn.mkEffectFn1 \t → do
    vdom ← EFn.runEffectFn1 (V.buildVDom spec) (toVDom (runThunk t))
    pure $ M.mkStep $ M.Step (M.extract vdom) { thunk: t, vdom } patchThunk haltThunk

  patchThunk ∷ EFn.EffectFn2 (ThunkState f i a w) (Thunk f i) (V.Step (Thunk f i) Node)
  patchThunk = EFn.mkEffectFn2 \state t2 → do
    let { vdom: prev, thunk: t1 } = state
    if Fn.runFn2 unsafeEqThunk t1 t2
      then pure $ M.mkStep $ M.Step (M.extract prev) state patchThunk haltThunk
      else do
        vdom ← EFn.runEffectFn2 M.step prev (toVDom (runThunk t2))
        pure $ M.mkStep $ M.Step (M.extract vdom) { vdom, thunk: t2 } patchThunk haltThunk

  haltThunk ∷ EFn.EffectFn1 (ThunkState f i a w) Unit
  haltThunk = EFn.mkEffectFn1 \state → do
    EFn.runEffectFn1 M.halt state.vdom

module Halogen.VDom.Thunk
  ( Thunk
  , buildThunk
  , runThunk
  , hoist
  , thunked
  , thunk1
  , thunk2
  , thunk3
  ) where

import Prelude

import Data.Function.Uncurried as Fn
import Effect.Uncurried as EFn
import Halogen.VDom as V
import Halogen.VDom.Machine as M
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Node (Node)

foreign import data ThunkArg ∷ Type

foreign import data ThunkId ∷ Type

data Thunk f i = Thunk ThunkId (Fn.Fn2 ThunkArg ThunkArg Boolean) (ThunkArg → f i) ThunkArg

unsafeThunkId ∷ ∀ a. a → ThunkId
unsafeThunkId = unsafeCoerce

instance functorThunk ∷ Functor f ⇒ Functor (Thunk f) where
  map f (Thunk a b c d) = Thunk a b (c >>> map f) d

hoist ∷ ∀ f g. (f ~> g) → Thunk f ~> Thunk g
hoist k (Thunk a b c d) = Thunk a b (c >>> k) d

thunk ∷ ∀ a f i. Fn.Fn4 ThunkId (Fn.Fn2 a a Boolean) (a → f i) a (Thunk f i)
thunk = Fn.mkFn4 \tid eqFn f a →
  Thunk tid
    (unsafeCoerce eqFn ∷ Fn.Fn2 ThunkArg ThunkArg Boolean)
    (unsafeCoerce f ∷ ThunkArg → f i)
    (unsafeCoerce a ∷ ThunkArg)

thunked ∷ ∀ a f i. (a → a → Boolean) → (a → f i) → a → Thunk f i
thunked eqFn f =
  let
    tid = unsafeThunkId { f }
    eqFn' = Fn.mkFn2 eqFn
  in
    \a → Fn.runFn4 thunk tid eqFn' f a

thunk1 ∷ ∀ a f i. Fn.Fn2 (a → f i) a (Thunk f i)
thunk1 = Fn.mkFn2 \f a → Fn.runFn4 thunk (unsafeThunkId f) Util.refEq f a

thunk2 ∷ ∀ a b f i. Fn.Fn3 (a → b → f i) a b (Thunk f i)
thunk2 =
  let
    eqFn = Fn.mkFn2 \a b →
      Fn.runFn2 Util.refEq a._1 b._1 &&
      Fn.runFn2 Util.refEq a._2 b._2
  in
    Fn.mkFn3 \f a b →
      Fn.runFn4 thunk (unsafeThunkId f) eqFn (\{ _1, _2 } → f _1 _2) { _1: a, _2: b }

thunk3 ∷ ∀ a b c f i. Fn.Fn4 (a → b → c → f i) a b c (Thunk f i)
thunk3 =
  let
    eqFn = Fn.mkFn2 \a b →
      Fn.runFn2 Util.refEq a._1 b._1 &&
      Fn.runFn2 Util.refEq a._2 b._2 &&
      Fn.runFn2 Util.refEq a._3 b._3
  in
    Fn.mkFn4 \f a b c →
      Fn.runFn4 thunk (unsafeThunkId f) eqFn (\{ _1, _2, _3 } → f _1 _2 _3) { _1: a, _2: b, _3: c }

runThunk ∷ ∀ f i. Thunk f i → f i
runThunk (Thunk _ _ render arg) = render arg

unsafeEqThunk ∷ ∀ f i. Fn.Fn2 (Thunk f i) (Thunk f i) Boolean
unsafeEqThunk = Fn.mkFn2 \(Thunk a1 b1 _ d1) (Thunk a2 b2 _ d2) →
  Fn.runFn2 Util.refEq a1 a2 &&
  Fn.runFn2 Util.refEq b1 b2 &&
  Fn.runFn2 Util.refEq d1 d2

type ThunkState f i a w =
  { thunk ∷ Thunk f i
  , vdom ∷ M.Step (V.VDom a w) Node
  }

buildThunk
  ∷ ∀ f i a w
  . (f i → V.VDom a w)
  → V.VDomSpec a w
  → V.Machine (Thunk f i) Node
buildThunk toVDom = renderThunk
  where
  renderThunk ∷ V.VDomSpec a w → V.Machine (Thunk f i) Node
  renderThunk spec = EFn.mkEffectFn1 \t → do
    vdom ← EFn.runEffectFn1 (V.buildVDom spec) (toVDom (runThunk t))
    pure $ M.mkStep $ M.Step (M.extract vdom) { thunk: t, vdom } patchThunk haltThunk

  patchThunk ∷ EFn.EffectFn2 (ThunkState f i a w) (Thunk f i) (V.Step (Thunk f i) Node)
  patchThunk = EFn.mkEffectFn2 \state t2 → do
    let { vdom: prev, thunk: t1 } = state
    if Fn.runFn2 unsafeEqThunk t1 t2
      then pure $ M.mkStep $ M.Step (M.extract prev) state patchThunk haltThunk
      else do
        vdom ← EFn.runEffectFn2 M.step prev (toVDom (runThunk t2))
        pure $ M.mkStep $ M.Step (M.extract vdom) { vdom, thunk: t2 } patchThunk haltThunk

  haltThunk ∷ EFn.EffectFn1 (ThunkState f i a w) Unit
  haltThunk = EFn.mkEffectFn1 \state → do
    EFn.runEffectFn1 M.halt state.vdom


Attempt to get url.

Attempt to get url.

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (attempt, launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, getValue, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, snoc, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F, readString)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.Types (URL)
import DOM.ServiceWorker (SERVICE_WORKER_CLIENT)
import DOM.ServiceWorker as ServiceWorker
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)

import Network.HTTP.Affjax (AJAX, get)
import Partial.Unsafe (unsafePartial)

type WeekDay = String

serviceWorkerURL :: URL
serviceWorkerURL = "worker.js"

main :: forall e
  . Eff ( ajax :: AJAX
        , console :: CONSOLE
        , dom :: DOM
        , err :: EXCEPTION
        , locale :: LOCALE
        , now :: NOW
        , ref :: REF
        , storage :: STORAGE
        , swclient :: SERVICE_WORKER_CLIENT
        | e ) Unit
main = do
  launchAff $ ServiceWorker.register serviceWorkerURL
  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey
  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  ready $ do
    spinner <- select ".loader"
    cardTemplate <- select ".cardTemplate"
    container <- select ".main"
    addDialog <- select ".dialog-container"
    citiesSelect <- select "#selectCityToAdd"
    body <- body

    stateRef <- newRef $ AppState { isLoading: true
                                  , visibleCards: Map.empty
                                  , selectedCities
                                  , spinner
                                  , cardTemplate
                                  , container
                                  , addDialog }

    on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body
    on' "click" "#butAddCancel" (\_ _ -> toggleAddDialog false addDialog) body
    on' "click" "#butAddCity" (\_ _ -> addSelectedCity stateRef citiesSelect addDialog) body
    on' "click" "#butRefresh" (\_ _ -> updateForecasts stateRef) body

    case storedSelectedCities of
      Just cities ->
        foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
      Nothing -> do
        -- The user is using the app for the first time, or the user has not
        -- saved any cities, so show the user some fake data. A real app in this
        -- scenario could guess the user's location via IP lookup and then inject
        -- that data into the page.
        updateForecastCard stateRef initialWeatherForecast
        saveSelectedCities stateRef

-- Methods to update/refresh the UI --

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  card <- getOrCreateCard stateRef cardData.key
  cardLastUpdatedElem <- find "> .card-last-updated" card
  cardLastUpdatedStr <- getText cardLastUpdatedElem

  dataIsOld <- if cardLastUpdatedStr == ""
    then pure false
    else do
      dataLastUpdatedJSDate <- parse cardData.created
      cardLastUpdatedJSDate <- parse cardLastUpdatedStr
      let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
      let cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
      pure $ cardLastUpdated > dataLastUpdated

  if dataIsOld
    then log $ "Old data: " <> cardLastUpdatedStr <> ", " <> cardData.created
    else do
      setText cardData.created cardLastUpdatedElem
      find "> .location" card >>= setText cardData.label
      find "> .description" card >>= setText current.text
      find "> .date" card >>= setText current.date
      find ".current .icon" card >>= setClass (getIconClass current.code) true
      find ".current .temperature .value" card >>= (setText $ show current.temp)
      find ".current .sunrise" card >>= setText astronomy.sunrise
      find ".current .sunset" card >>= setText astronomy.sunset
      find ".current .humidity" card >>= (setText $ show humidity <> "%")
      find ".current .wind .value" card >>= (setText $ show wind.speed)
      find ".current .wind .direction" card >>= (setText $ show wind.direction)

      nextDays <- find ".future .oneday" card >>= toArray
      ndw <- nextDaysOfWeek
      foreachE (zip3 nextDays forcast ndw) updateNextDay

      AppState state <- readRef stateRef
      when state.isLoading do
        hide state.spinner
        modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

      where
        channel = cardData.channel
        astronomy = channel.astronomy
        current = channel.item.condition
        forcast = channel.item.forecast
        humidity = channel.atmosphere.humidity
        wind = channel.wind

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t = do
  find ".icon" c >>= setClass (getIconClass daily.code) true
  find ".date" c >>= setText wd
  find ".temp-high .value" c >>= (setText $ show daily.high)
  find ".temp-low .value" c >>= (setText $ show daily.low)
  where
    c = get1 t
    daily = get2 t
    wd = get3 t

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (console :: CONSOLE, dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

addSelectedCity :: forall e
   . Ref AppState
  -> JQuery
  -> JQuery
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         , storage :: STORAGE
         | e) Unit
addSelectedCity stateRef citiesSelect addDialog = do
  selectedOpt <- find "option:selected" citiesSelect
  label <- getText selectedOpt
  value <- getValue selectedOpt
  case runExcept $ readString value of
    Left err -> log $ show err
    Right key -> do
      getForecast stateRef key label
      modifyRef stateRef $ storeSelectedCity $ SelectedCity { key, label }
      saveSelectedCities stateRef
      toggleAddDialog false addDialog

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    requestAttempt <- attempt $ get url
    case requestAttempt of
      Left err ->
        liftEff $ updateForecastCard stateRef initialWeatherForecast
      Right request ->
        case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
          Left err ->
            liftEff $ log (show err)
          Right response ->
            case fromWeatherService key label response of
              Just cardData ->
                liftEff $ updateForecastCard stateRef cardData
              Nothing ->
                liftEff $ log "Bad weather service response"

-- | Iterate all of the cards and attempt to get the latest forecast data.
updateForecasts
  :: forall e
   . Ref AppState
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , dom :: DOM
         , err :: EXCEPTION
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e
         ) Unit
updateForecasts stateRef = do
  AppState state <- readRef stateRef
  foreachE state.selectedCities \(SelectedCity { key, label }) -> getForecast stateRef key label

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

storeSelectedCity :: SelectedCity -> AppState -> AppState
storeSelectedCity city (AppState state) =
  AppState state { selectedCities = snoc state.selectedCities city }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, getValue, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, snoc, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F, readString)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.Types (URL)
import DOM.ServiceWorker (SERVICE_WORKER_CLIENT)
import DOM.ServiceWorker as ServiceWorker
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)

import Network.HTTP.Affjax (AJAX, get)
import Partial.Unsafe (unsafePartial)

type WeekDay = String

serviceWorkerURL :: URL
serviceWorkerURL = "worker.js"

main :: forall e
  . Eff ( ajax :: AJAX
        , console :: CONSOLE
        , dom :: DOM
        , err :: EXCEPTION
        , locale :: LOCALE
        , now :: NOW
        , ref :: REF
        , storage :: STORAGE
        , swclient :: SERVICE_WORKER_CLIENT
        | e ) Unit
main = do
  launchAff $ ServiceWorker.register serviceWorkerURL
  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey
  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  ready $ do
    spinner <- select ".loader"
    cardTemplate <- select ".cardTemplate"
    container <- select ".main"
    addDialog <- select ".dialog-container"
    citiesSelect <- select "#selectCityToAdd"
    body <- body

    stateRef <- newRef $ AppState { isLoading: true
                                  , visibleCards: Map.empty
                                  , selectedCities
                                  , spinner
                                  , cardTemplate
                                  , container
                                  , addDialog }

    on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body
    on' "click" "#butAddCancel" (\_ _ -> toggleAddDialog false addDialog) body
    on' "click" "#butAddCity" (\_ _ -> addSelectedCity stateRef citiesSelect addDialog) body
    on' "click" "#butRefresh" (\_ _ -> updateForecasts stateRef) body

    case storedSelectedCities of
      Just cities ->
        foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
      Nothing -> do
        -- The user is using the app for the first time, or the user has not
        -- saved any cities, so show the user some fake data. A real app in this
        -- scenario could guess the user's location via IP lookup and then inject
        -- that data into the page.
        updateForecastCard stateRef initialWeatherForecast
        saveSelectedCities stateRef

-- Methods to update/refresh the UI --

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  card <- getOrCreateCard stateRef cardData.key
  cardLastUpdatedElem <- find "> .card-last-updated" card
  cardLastUpdatedStr <- getText cardLastUpdatedElem

  dataIsOld <- if cardLastUpdatedStr == ""
    then pure false
    else do
      dataLastUpdatedJSDate <- parse cardData.created
      cardLastUpdatedJSDate <- parse cardLastUpdatedStr
      let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
      let cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
      pure $ cardLastUpdated > dataLastUpdated

  if dataIsOld
    then log $ "Old data: " <> cardLastUpdatedStr <> ", " <> cardData.created
    else do
      setText cardData.created cardLastUpdatedElem
      find "> .location" card >>= setText cardData.label
      find "> .description" card >>= setText current.text
      find "> .date" card >>= setText current.date
      find ".current .icon" card >>= setClass (getIconClass current.code) true
      find ".current .temperature .value" card >>= (setText $ show current.temp)
      find ".current .sunrise" card >>= setText astronomy.sunrise
      find ".current .sunset" card >>= setText astronomy.sunset
      find ".current .humidity" card >>= (setText $ show humidity <> "%")
      find ".current .wind .value" card >>= (setText $ show wind.speed)
      find ".current .wind .direction" card >>= (setText $ show wind.direction)

      nextDays <- find ".future .oneday" card >>= toArray
      ndw <- nextDaysOfWeek
      foreachE (zip3 nextDays forcast ndw) updateNextDay

      AppState state <- readRef stateRef
      when state.isLoading do
        hide state.spinner
        modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

      where
        channel = cardData.channel
        astronomy = channel.astronomy
        current = channel.item.condition
        forcast = channel.item.forecast
        humidity = channel.atmosphere.humidity
        wind = channel.wind

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t = do
  find ".icon" c >>= setClass (getIconClass daily.code) true
  find ".date" c >>= setText wd
  find ".temp-high .value" c >>= (setText $ show daily.high)
  find ".temp-low .value" c >>= (setText $ show daily.low)
  where
    c = get1 t
    daily = get2 t
    wd = get3 t

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (console :: CONSOLE, dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

addSelectedCity :: forall e
   . Ref AppState
  -> JQuery
  -> JQuery
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         , storage :: STORAGE
         | e) Unit
addSelectedCity stateRef citiesSelect addDialog = do
  selectedOpt <- find "option:selected" citiesSelect
  label <- getText selectedOpt
  value <- getValue selectedOpt
  case runExcept $ readString value of
    Left err -> log $ show err
    Right key -> do
      getForecast stateRef key label
      modifyRef stateRef $ storeSelectedCity $ SelectedCity { key, label }
      saveSelectedCities stateRef
      toggleAddDialog false addDialog

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Iterate all of the cards and attempt to get the latest forecast data.
updateForecasts
  :: forall e
   . Ref AppState
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , dom :: DOM
         , err :: EXCEPTION
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e
         ) Unit
updateForecasts stateRef = do
  AppState state <- readRef stateRef
  foreachE state.selectedCities \(SelectedCity { key, label }) -> getForecast stateRef key label

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

storeSelectedCity :: SelectedCity -> AppState -> AppState
storeSelectedCity city (AppState state) =
  AppState state { selectedCities = snoc state.selectedCities city }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }


Don't gather classes in separate array

Don't gather classes in separate array

Original commit d7e13d7eec42c76713aa508d3195f4dc3eecd531

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as C
import Data.Argonaut.Core (JArray, JBoolean, JNull, JString, Json, JObject, foldJson, foldJsonObject)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (length, toUnfoldable, (:), concat, (!!), foldMap, concatMap)
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, fromFoldable, keys, values, foldMap, toUnfoldable) as StrMap
import Data.Tuple (uncurry, Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

data CSharpClass = CSClass { name :: String, properties :: StrMap.StrMap CSharpType }
data CSharpType
    = CSClassType CSharpClass
    | CSArray CSharpType
    | CSObject
    | CSBool
    | CSDouble
    | CSString

makeCSharpTypeFromJson :: String -> Json -> CSharpType
makeCSharpTypeFromJson name json = foldJson
    (const $ CSObject)
    (\b -> CSBool)
    (\x -> CSDouble)
    (\s -> CSString)
    (case _ of
        [] -> CSArray CSObject
        a ->
            let elementType = makeCSharpTypeFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            CSArray elementType)
    (\o ->
        let props = mapProperties o in
        CSClassType (CSClass { name: name, properties: props }))
    json

mapProperties :: StrMap.StrMap Json -> StrMap.StrMap CSharpType
mapProperties sm = StrMap.fromFoldable results
  where mapper (Tuple n j) = Tuple n (makeCSharpTypeFromJson n j)
        results = map mapper (unfold sm)

singularize :: String -> String
singularize s = "OneOf" <> s

-- This is a travesty.  Try putting this function definition
-- in the where clause below.
unfold :: forall a. StrMap.StrMap a -> Array (Tuple String a)
unfold sm = StrMap.toUnfoldable sm

gatherClassesFromType :: CSharpType -> Array CSharpClass
gatherClassesFromType (CSClassType c) =
    let CSClass { name, properties } = c in
    c : (concatMap gatherClassesFromType (StrMap.values properties))
gatherClassesFromType (CSArray t) = gatherClassesFromType t
gatherClassesFromType _ = []

renderCSharpType :: CSharpType -> String
renderCSharpType (CSArray a) = (renderCSharpType a) <> "[]"
renderCSharpType (CSClassType (CSClass { name, properties })) = name
renderCSharpType CSObject = "object"
renderCSharpType CSBool = "bool"
renderCSharpType CSDouble = "double"
renderCSharpType CSString = "string"

renderCSharpClass :: CSharpClass -> String
renderCSharpClass (CSClass { name, properties }) =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name csType = "    public " <> (renderCSharpType csType) <> " " <> name <> " { get; set; }"

renderCSharpClasses :: Array CSharpClass -> String
renderCSharpClasses classes =
    foldMap (\c -> (renderCSharpClass c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeCSharpTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderCSharpClasses

module Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as C
import Data.Argonaut.Core (JArray, JBoolean, JNull, JString, Json, JObject, foldJson, foldJsonObject)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (length, toUnfoldable, (:), concat, (!!), foldMap)
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, fromFoldable, keys, values, foldMap, toUnfoldable) as StrMap
import Data.Tuple (uncurry, Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

data CSharpClass = CSClass { name :: String, properties :: StrMap.StrMap CSharpType }
data CSharpType
    = CSClassType CSharpClass
    | CSArray CSharpType
    | CSObject
    | CSBool
    | CSDouble
    | CSString

gatherCSharpClassesFromJson :: String -> Json -> Tuple CSharpType (Array CSharpClass)
gatherCSharpClassesFromJson name json = foldJson
    (const $ Tuple CSObject [])
    (\b -> Tuple CSBool [])
    (\x -> Tuple CSDouble [])
    (\s -> Tuple CSString [])
    (case _ of
        [] -> Tuple (CSArray CSObject) []
        a ->
            let Tuple et classes = gatherCSharpClassesFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            Tuple (CSArray et) classes)
    (\o ->
        let Tuple props classes = mapProperties o
            c = CSClass { name: name, properties: props } in
        Tuple (CSClassType c) (c : classes))
    json

mapStrMap :: forall a b. (String -> a -> b) -> StrMap.StrMap a -> Array b
mapStrMap f sm = map (uncurry f) (StrMap.toUnfoldable sm)

singularize :: String -> String
singularize s = "OneOf" <> s

mapProperties :: StrMap.StrMap Json -> Tuple (StrMap.StrMap CSharpType) (Array CSharpClass)
mapProperties sm = Tuple propMap classes
  where mapper (Tuple n j) = let Tuple t classes = gatherCSharpClassesFromJson n j
                              in Tuple (Tuple n t) classes
        results = map mapper (StrMap.toUnfoldable sm)
        propMap = StrMap.fromFoldable $ map fst results
        classes = concat $ map snd results

renderCSharpType :: CSharpType -> String
renderCSharpType (CSArray a) = (renderCSharpType a) <> "[]"
renderCSharpType (CSClassType (CSClass { name, properties })) = name
renderCSharpType CSObject = "object"
renderCSharpType CSBool = "bool"
renderCSharpType CSDouble = "double"
renderCSharpType CSString = "string"

renderCSharpClass :: CSharpClass -> String
renderCSharpClass (CSClass { name, properties }) =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name csType = "    public " <> (renderCSharpType csType) <> " " <> name <> " { get; set; }"

renderCSharpClasses :: Array CSharpClass -> String
renderCSharpClasses classes =
    foldMap (\c -> (renderCSharpClass c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> gatherCSharpClassesFromJson "TopLevel"
    <#> snd
    <#> renderCSharpClasses


error dialog fix in filesystem search produce error if root of searched folder has no children

{-
Copyright 2015 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 FileSystem.Routing
 ( Routes(..)
 , routing
 , routeSignal
 ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad (when)
import Control.Monad.Aff (Aff(), Canceler(), cancel, forkAff, attempt)
import Control.Monad.Aff.AVar (makeVar', takeVar, putVar, modifyVar, AVar())
import Control.Monad.Eff.Exception (error, message, Error())
import Control.MonadPlus (guard)
import Control.UI.Browser (replaceLocation)

import Data.Array (filter, mapMaybe)
import Data.Either (Either(..), either)
import Data.Foldable (foldl, traverse_)
import Data.Functor (($>))
import Data.Functor.Eff (liftEff)
import Data.Functor.Coproduct (left)
import Data.Lens ((%~), (<>~), _1, _2)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (mempty)
import Data.Path.Pathy ((</>), rootDir, parseAbsDir, sandbox, currentDir)
import Data.These (These(..))
import Data.Tuple (Tuple(..), uncurry)

import Halogen.Driver (Driver())
import Halogen.Query (action)

import Text.SlamSearch (mkQuery)
import Text.SlamSearch.Printer (strQuery)
import Text.SlamSearch.Types (SearchQuery())

import FileSystem
import FileSystem.Dialog as Dialog
import FileSystem.Effects
import FileSystem.Items as Items
import FileSystem.Routing.Search (isSearchQuery, searchPath, filterByQuery)
import FileSystem.Search as Search
import Model.Common (browseURL)
import Model.Item (Item(..))
import Model.Resource (Resource(..), getPath)
import Model.Salt (Salt(..), newSalt)
import Model.Sort (Sort(..), string2sort)
import Quasar.Aff (mountInfo, children)
import Routing (matchesAff)
import Routing.Match (Match(), eitherMatch)
import Routing.Match.Class (param)
import Utils.Path (DirPath(), hidePath, renderPath)

data Routes
  = Salted Sort SearchQuery Salt
  | SortAndQ Sort SearchQuery
  | Sort Sort
  | Index

routing :: Match Routes
routing = salted <|> bothRoute <|> oneRoute <|> index
  where
  salted = Salted <$> sort <*> query <*> salt
  bothRoute = SortAndQ <$> sort <*> query
  oneRoute = Sort <$> sort
  index = pure Index
  sort = eitherMatch (string2sort <$> param "sort")
  query = eitherMatch (mkQuery <$> param "q")
  salt = eitherMatch (getSalt <$> param "salt")

getSalt :: String -> Either String Salt
getSalt input =
  if input /= ""
  then Right $ Salt input
  else Left "incorrect salt"

initialAVar :: Tuple (Canceler FileSystemEffects) (M.Map Int Int)
initialAVar = Tuple mempty M.empty

routeSignal :: Driver QueryP FileSystemRawEffects
               -> Aff FileSystemEffects Unit
routeSignal driver = do
  avar <- makeVar' initialAVar
  routeTpl <- matchesAff routing
  pure unit
  uncurry (redirects driver avar) routeTpl

redirects
  :: Driver QueryP FileSystemRawEffects
  -> AVar (Tuple (Canceler FileSystemEffects) (M.Map Int Int))
  -> Maybe Routes -> Routes
  -> Aff FileSystemEffects Unit
redirects _ _ _ Index = updateURL Nothing Asc Nothing rootDir
redirects _ _ _ (Sort sort) = updateURL Nothing sort Nothing rootDir
redirects _ _ _ (SortAndQ sort query) =
  let queryParts = splitQuery query
  in updateURL queryParts.query sort Nothing queryParts.path
redirects driver var mbOld (Salted sort query salt) = do
  Tuple canceler _ <- takeVar var
  cancel canceler $ error "cancel search"
  putVar var initialAVar
  driver $ toItems $ Items.SetIsSearching $ isSearchQuery query
  if isNewPage
    then do
    driver $ toItems Items.Reset
    driver $ toFs $ SetPath queryParts.path
    driver $ toFs $ SetSort sort
    driver $ toFs $ SetSalt salt
    driver $ toFs $ SetIsMount false
    driver $ toSearch $ Search.SetLoading true
    driver $ toSearch $ Search.SetValue $ maybe (This "") That queryParts.query
    driver $ toSearch $ Search.SetValid true
    listPath query zero var queryParts.path driver
    maybe (checkMount queryParts.path driver) (const $ pure unit) queryParts.query
    else
    driver $ toSearch $ Search.SetLoading false
  where

  queryParts = splitQuery query
  isNewPage = fromMaybe true do
    old <- mbOld
    Tuple oldQuery oldSalt <- case old of
      Salted _ oldQuery oldSalt -> pure $ Tuple oldQuery oldSalt
      _ -> Nothing
    pure $ oldQuery /= query || oldSalt == salt

checkMount
  :: DirPath
  -> Driver QueryP FileSystemRawEffects
  -> Aff FileSystemEffects Unit
checkMount path driver = do
  result <- attempt $ mountInfo (Database path)
  case result of
    Left _ -> pure unit
    Right _ -> driver $ left $ action $ SetIsMount true

listPath
  :: SearchQuery
  -> Int
  -> AVar (Tuple (Canceler FileSystemEffects) (M.Map Int Int))
  -> DirPath
  -> Driver QueryP FileSystemRawEffects
  -> Aff FileSystemEffects Unit
listPath query deep var dir driver = do
  modifyVar (_2 %~ M.alter (maybe one (add one >>> pure))  deep) var
  canceler <- forkAff goDeeper
  modifyVar (_1 <>~ canceler) var
  where
  goDeeper = do
    (attempt $ children dir) >>= either sendError getChildren
    modifyVar (_2 %~ M.update (\v -> guard (v > one) $> (v - one)) deep) var
    Tuple c r <- takeVar var
    if (foldl (+) zero $ M.values r) == zero
      then do
      driver $ toSearch $ Search.SetLoading false
      putVar var initialAVar
      else
      putVar var (Tuple c r)

  sendError :: Error -> Aff FileSystemEffects Unit
  sendError err =
    when ((not $ isSearchQuery query) || deep == zero)
    $ driver $ toDialog $ Dialog.Show
    $ Dialog.Error ("There is a problem listing current directory: "
                   <> message err)

  getChildren :: Array Resource -> Aff FileSystemEffects Unit
  getChildren ress = do
    let next = mapMaybe (either (const Nothing) Just <<< getPath) ress
        toAdd = map Item $ filter (filterByQuery query) ress

    driver $ toItems $ Items.Adds toAdd
    traverse_ (\n -> listPath query (deep + one) var n driver)
      (guard (isSearchQuery query) *> next)

updateURL :: Maybe String -> Sort -> Maybe Salt -> DirPath
             -> Aff FileSystemEffects Unit
updateURL query sort salt path = liftEff do
  salt' <- maybe newSalt pure salt
  replaceLocation $ browseURL query sort salt' path

splitQuery :: SearchQuery -> { path :: DirPath, query :: Maybe String }
splitQuery q =
  { path: path
  , query: query
  }
  where
  path = rootDir </> fromMaybe currentDir
         (searchPath q >>= parseAbsDir >>= sandbox rootDir)
  query = do
    guard $ isSearchQuery q
    pure $ hidePath (renderPath $ Right path) (strQuery q)

{-
Copyright 2015 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 FileSystem.Routing
 ( Routes(..)
 , routing
 , routeSignal
 ) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff(), Canceler(), cancel, forkAff, attempt)
import Control.Monad.Aff.AVar (makeVar', takeVar, putVar, modifyVar, AVar())
import Control.Monad.Eff.Exception (error, message, Error())
import Control.MonadPlus (guard)
import Control.UI.Browser (replaceLocation)

import Data.Array (filter, mapMaybe)
import Data.Either (Either(..), either)
import Data.Foldable (foldl, traverse_)
import Data.Functor (($>))
import Data.Functor.Eff (liftEff)
import Data.Functor.Coproduct (left)
import Data.Lens ((%~), (<>~), _1, _2)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (mempty)
import Data.Path.Pathy ((</>), rootDir, parseAbsDir, sandbox, currentDir)
import Data.These (These(..))
import Data.Tuple (Tuple(..), uncurry)

import Halogen.Driver (Driver())
import Halogen.Query (action)

import Text.SlamSearch (mkQuery)
import Text.SlamSearch.Printer (strQuery)
import Text.SlamSearch.Types (SearchQuery())

import FileSystem
import FileSystem.Dialog as Dialog
import FileSystem.Effects
import FileSystem.Items as Items
import FileSystem.Routing.Search (isSearchQuery, searchPath, filterByQuery)
import FileSystem.Search as Search
import Model.Common (browseURL)
import Model.Item (Item(..))
import Model.Resource (Resource(..), getPath)
import Model.Salt (Salt(..), newSalt)
import Model.Sort (Sort(..), string2sort)
import Quasar.Aff (mountInfo, children)
import Routing (matchesAff)
import Routing.Match (Match(), eitherMatch)
import Routing.Match.Class (param)
import Utils.Path (DirPath(), hidePath, renderPath)

data Routes
  = Salted Sort SearchQuery Salt
  | SortAndQ Sort SearchQuery
  | Sort Sort
  | Index

routing :: Match Routes
routing = salted <|> bothRoute <|> oneRoute <|> index
  where
  salted = Salted <$> sort <*> query <*> salt
  bothRoute = SortAndQ <$> sort <*> query
  oneRoute = Sort <$> sort
  index = pure Index
  sort = eitherMatch (string2sort <$> param "sort")
  query = eitherMatch (mkQuery <$> param "q")
  salt = eitherMatch (getSalt <$> param "salt")

getSalt :: String -> Either String Salt
getSalt input =
  if input /= ""
  then Right $ Salt input
  else Left "incorrect salt"

initialAVar :: Tuple (Canceler FileSystemEffects) (M.Map Int Int)
initialAVar = Tuple mempty M.empty

routeSignal :: Driver QueryP FileSystemRawEffects
               -> Aff FileSystemEffects Unit
routeSignal driver = do
  avar <- makeVar' initialAVar
  routeTpl <- matchesAff routing
  pure unit
  uncurry (redirects driver avar) routeTpl

redirects :: Driver QueryP FileSystemRawEffects
          -> AVar (Tuple (Canceler FileSystemEffects) (M.Map Int Int))
          -> Maybe Routes -> Routes
          -> Aff FileSystemEffects Unit
redirects _ _ _ Index = updateURL Nothing Asc Nothing rootDir
redirects _ _ _ (Sort sort) = updateURL Nothing sort Nothing rootDir
redirects _ _ _ (SortAndQ sort query) =
  let queryParts = splitQuery query
  in updateURL queryParts.query sort Nothing queryParts.path
redirects driver var mbOld (Salted sort query salt) = do
  Tuple canceler _ <- takeVar var
  cancel canceler $ error "cancel search"
  putVar var initialAVar
  driver $ toItems $ Items.SetIsSearching $ isSearchQuery query
  if isNewPage
    then do
    driver $ toItems Items.Reset
    driver $ toFs $ SetPath queryParts.path
    driver $ toFs $ SetSort sort
    driver $ toFs $ SetSalt salt
    driver $ toFs $ SetIsMount false
    driver $ toSearch $ Search.SetLoading true
    driver $ toSearch $ Search.SetValue $ maybe (This "") That queryParts.query
    driver $ toSearch $ Search.SetValid true
    listPath query zero var queryParts.path driver
    maybe (checkMount queryParts.path driver) (const $ pure unit) queryParts.query
    else
    driver $ toSearch $ Search.SetLoading false
  where

  queryParts = splitQuery query
  isNewPage = fromMaybe true do
    old <- mbOld
    Tuple oldQuery oldSalt <- case old of
      Salted _ oldQuery oldSalt -> pure $ Tuple oldQuery oldSalt
      _ -> Nothing
    pure $ oldQuery /= query || oldSalt == salt

checkMount :: DirPath -> Driver QueryP FileSystemRawEffects
              -> Aff FileSystemEffects Unit
checkMount path driver = do
  result <- attempt $ mountInfo (Database path)
  case result of
    Left _ -> pure unit
    Right _ -> driver $ left $ action $ SetIsMount true

listPath :: SearchQuery -> Int
            -> AVar (Tuple (Canceler FileSystemEffects) (M.Map Int Int))
            -> DirPath -> Driver QueryP FileSystemRawEffects
            -> Aff FileSystemEffects Unit
listPath query deep var dir driver = do
  modifyVar (_2 %~ M.alter (maybe one (add one >>> pure))  deep) var
  canceler <- forkAff goDeeper
  modifyVar (_1 <>~ canceler) var
  where
  goDeeper = do
    (attempt $ children dir) >>= either sendError getChildren
    modifyVar (_2 %~ M.update (\v -> guard (v > one) $> (v - one)) deep) var
    Tuple c r <- takeVar var
    if (foldl (+) zero $ M.values r) == zero
      then do
      driver $ toSearch $ Search.SetLoading false
      putVar var initialAVar
      else
      putVar var (Tuple c r)

  sendError :: Error -> Aff FileSystemEffects Unit
  sendError err =
    driver $ toDialog $ Dialog.Show
    $ Dialog.Error ("There is a problem listing current directory: "
                   <> message err)

  getChildren :: Array Resource -> Aff FileSystemEffects Unit
  getChildren ress = do
    let next = mapMaybe (either (const Nothing) Just <<< getPath) ress
        toAdd = map Item $ filter (filterByQuery query) ress

    driver $ toItems $ Items.Adds toAdd
    traverse_ (\n -> listPath query (deep + one) var n driver)
      $ if isSearchQuery query
        then do
          next
        else [ ]

updateURL :: Maybe String -> Sort -> Maybe Salt -> DirPath
             -> Aff FileSystemEffects Unit
updateURL query sort salt path = liftEff do
  salt' <- maybe newSalt pure salt
  replaceLocation $ browseURL query sort salt' path

splitQuery :: SearchQuery -> { path :: DirPath, query :: Maybe String }
splitQuery q =
  { path: path
  , query: query
  }
  where
  path = rootDir </> fromMaybe currentDir
         (searchPath q >>= parseAbsDir >>= sandbox rootDir)
  query = do
    guard $ isSearchQuery q
    pure $ hidePath (renderPath $ Right path) (strQuery q)


Remap the input too during 'renderWidget'

module Halogen.VDom.Types
  ( VDom(..)
  , renderWidget
  , Graft
  , GraftX(..)
  , graft
  , unGraft
  , runGraft
  , ElemName(..)
  , Namespace(..)
  ) where

import Prelude
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple)
import Unsafe.Coerce (unsafeCoerce)

-- | The core virtual-dom tree type, where `a` is the type of attributes,
-- | and `w` is the type of "widgets". Widgets are machines that have complete
-- | control over the lifecycle of some `DOM.Node`.
-- |
-- | The `Grafted` constructor and associated machinery enables `bimap`
-- | fusion using a Coyoneda-like encoding.
data VDom a w
  = Text String
  | Elem (Maybe Namespace) ElemName a (Array (VDom a w))
  | Keyed (Maybe Namespace) ElemName a (Array (Tuple String (VDom a w)))
  | Widget w
  | Grafted (Graft a w)

instance functorVDom ∷ Functor (VDom a) where
  map g (Text a) = Text a
  map g (Grafted a) = Grafted (map g a)
  map g a = Grafted (graft (Graft identity g a))

instance bifunctorVDom ∷ Bifunctor VDom where
  bimap f g (Text a) = Text a
  bimap f g (Grafted a) = Grafted (bimap f g a)
  bimap f g a = Grafted (graft (Graft f g a))

-- | Replaces "widgets" in the `VDom` with the ability to turn them into other
-- | `VDom` nodes.
-- |
-- | Using this function will fuse any `Graft`s present in the `VDom`.
renderWidget ∷ ∀ a b w x. (a → b) → (w → VDom b x) → VDom a w → VDom b x
renderWidget f g = case _ of
  Text a → Text a
  Elem ns n a ch → Elem ns n (f a) (map (renderWidget f g) ch)
  Keyed ns n a ch → Keyed ns n (f a) (map (map (renderWidget f g)) ch)
  Widget w → g w
  Grafted gaw → renderWidget f g (runGraft gaw)

foreign import data Graft ∷ Type → Type → Type

instance functorGraft ∷ Functor (Graft a) where
  map g = unGraft \(Graft f' g' a) → graft (Graft f' (g <<< g') a)

instance bifunctorGraft ∷ Bifunctor Graft where
  bimap f g = unGraft \(Graft f' g' a) → graft (Graft (f <<< f') (g <<< g') a)

data GraftX a a' w w' =
  Graft (a → a') (w → w') (VDom a w)

graft
  ∷ ∀ a a' w w'
  . GraftX a a' w w'
  → Graft a' w'
graft = unsafeCoerce

unGraft
  ∷ ∀ a' w' r
  . (∀ a w. GraftX a a' w w' → r)
  → Graft a' w'
  → r
unGraft f = f <<< unsafeCoerce

runGraft
  ∷ ∀ a' w'
  . Graft a' w'
  → VDom a' w'
runGraft =
  unGraft \(Graft fa fw v) →
    let
      go (Text s) = Text s
      go (Elem ns n a ch) = Elem ns n (fa a) (map go ch)
      go (Keyed ns n a ch) = Keyed ns n (fa a) (map (map go) ch)
      go (Widget w) = Widget (fw w)
      go (Grafted g) = Grafted (bimap fa fw g)
    in
      go v

newtype ElemName = ElemName String

derive instance newtypeElemName ∷ Newtype ElemName _
derive newtype instance eqElemName ∷ Eq ElemName
derive newtype instance ordElemName ∷ Ord ElemName

newtype Namespace = Namespace String

derive instance newtypeNamespace ∷ Newtype Namespace _
derive newtype instance eqNamespace ∷ Eq Namespace
derive newtype instance ordNamespace ∷ Ord Namespace

module Halogen.VDom.Types
  ( VDom(..)
  , renderWidget
  , Graft
  , GraftX(..)
  , graft
  , unGraft
  , runGraft
  , ElemName(..)
  , Namespace(..)
  ) where

import Prelude
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple)
import Unsafe.Coerce (unsafeCoerce)

-- | The core virtual-dom tree type, where `a` is the type of attributes,
-- | and `w` is the type of "widgets". Widgets are machines that have complete
-- | control over the lifecycle of some `DOM.Node`.
-- |
-- | The `Grafted` constructor and associated machinery enables `bimap`
-- | fusion using a Coyoneda-like encoding.
data VDom a w
  = Text String
  | Elem (Maybe Namespace) ElemName a (Array (VDom a w))
  | Keyed (Maybe Namespace) ElemName a (Array (Tuple String (VDom a w)))
  | Widget w
  | Grafted (Graft a w)

instance functorVDom ∷ Functor (VDom a) where
  map g (Text a) = Text a
  map g (Grafted a) = Grafted (map g a)
  map g a = Grafted (graft (Graft identity g a))

instance bifunctorVDom ∷ Bifunctor VDom where
  bimap f g (Text a) = Text a
  bimap f g (Grafted a) = Grafted (bimap f g a)
  bimap f g a = Grafted (graft (Graft f g a))

-- | Replaces "widgets" in the `VDom` with the ability to turn them into other
-- | `VDom` nodes.
-- |
-- | Using this function will fuse any `Graft`s present in the `VDom`.
renderWidget ∷ ∀ a w x. (w → VDom a x) → VDom a w → VDom a x
renderWidget f = case _ of
  Text a → Text a
  Elem ns n a ch → Elem ns n a (map (renderWidget f) ch)
  Keyed ns n a ch → Keyed ns n a (map (map (renderWidget f)) ch)
  Widget w → f w
  Grafted g → Grafted $ unGraft (\(Graft fa fw v) →
    graft (Graft identity identity (renderWidget f (bimap fa fw v)))) g

foreign import data Graft ∷ Type → Type → Type

instance functorGraft ∷ Functor (Graft a) where
  map g = unGraft \(Graft f' g' a) → graft (Graft f' (g <<< g') a)

instance bifunctorGraft ∷ Bifunctor Graft where
  bimap f g = unGraft \(Graft f' g' a) → graft (Graft (f <<< f') (g <<< g') a)

data GraftX a a' w w' =
  Graft (a → a') (w → w') (VDom a w)

graft
  ∷ ∀ a a' w w'
  . GraftX a a' w w'
  → Graft a' w'
graft = unsafeCoerce

unGraft
  ∷ ∀ a' w' r
  . (∀ a w. GraftX a a' w w' → r)
  → Graft a' w'
  → r
unGraft f = f <<< unsafeCoerce

runGraft
  ∷ ∀ a' w'
  . Graft a' w'
  → VDom a' w'
runGraft =
  unGraft \(Graft fa fw v) →
    let
      go (Text s) = Text s
      go (Elem ns n a ch) = Elem ns n (fa a) (map go ch)
      go (Keyed ns n a ch) = Keyed ns n (fa a) (map (map go) ch)
      go (Widget w) = Widget (fw w)
      go (Grafted g) = Grafted (bimap fa fw g)
    in
      go v

newtype ElemName = ElemName String

derive instance newtypeElemName ∷ Newtype ElemName _
derive newtype instance eqElemName ∷ Eq ElemName
derive newtype instance ordElemName ∷ Ord ElemName

newtype Namespace = Namespace String

derive instance newtypeNamespace ∷ Newtype Namespace _
derive newtype instance eqNamespace ∷ Eq Namespace
derive newtype instance ordNamespace ∷ Ord Namespace