update LambdaCube.WebGL.Mesh to use the genearted Mesh module

module LambdaCube.WebGL.Mesh where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Data.StrMap as StrMap
import Data.Maybe
import Data.Maybe (fromJust)
import Data.Array
import Data.Tuple
import Data.Int
import Data.List as List

import Partial.Unsafe (unsafeCrashWith, unsafePartial)

import LambdaCube.Mesh
import LambdaCube.IR
import LambdaCube.LinearBase
import LambdaCube.WebGL.Type
import LambdaCube.WebGL.Data
import LambdaCube.WebGL.Input

type GPUData =
    { primitive :: Primitive
    , streams   :: StrMap.StrMap (Stream Buffer)
    , indices   :: Maybe (IndexStream Buffer)
    }

data GPUMesh = GPUMesh
    { meshData  :: Mesh
    , gpuData   :: GPUData
    }

addMesh :: WebGLPipelineInput -> String -> GPUMesh -> Array String -> GFX GLObject
addMesh input slotName (GPUMesh mesh) objUniNames = case StrMap.lookup slotName input.schema.slots of
    Nothing -> throwException $ error "addMesh: slot not found"
    Just slotSchema -> do
      -- select proper attributes
      let filterStream (Tuple n s) = StrMap.member n slotSchema.attributes
      addObject input slotName mesh.gpuData.primitive mesh.gpuData.indices (StrMap.fromFoldable $ List.filter filterStream $ StrMap.toList mesh.gpuData.streams) objUniNames

compileMesh :: Mesh -> GFX GPUMesh
compileMesh (Mesh mesh) = unsafePartial $ do
    let mkIndexBuf v = do
            iBuf <- compileBuffer [Array ArrWord16 (toArray v)]
            pure $ Just {buffer: iBuf, arrIdx: 0, start: 0, length: length v}
    vBuf <- compileBuffer $ map meshAttrToArray $ List.toUnfoldable (StrMap.values mesh.mAttributes)
    Tuple prim indices <- case mesh.mPrimitive of
        P_Points            -> pure $ Tuple PointList     Nothing
        P_TriangleStrip     -> pure $ Tuple TriangleStrip Nothing
        P_Triangles         -> pure $ Tuple TriangleList  Nothing
        P_TriangleStripI v  -> Tuple TriangleStrip <$> mkIndexBuf v
        P_TrianglesI v      -> Tuple TriangleList <$> mkIndexBuf v
    let streams = StrMap.fromFoldable $ List.zipWith (\i (Tuple n a) -> Tuple n (meshAttrToStream vBuf i a))
                                                     (List.range 0 $ fromJust $ fromNumber $ StrMap.size mesh.mAttributes)
                                                     (StrMap.toList mesh.mAttributes)
        gpuData = {primitive: prim, streams: streams, indices: indices}
    pure $ GPUMesh {meshData: Mesh mesh, gpuData: gpuData}

meshAttrToArray :: MeshAttribute -> LCArray
meshAttrToArray a = case a of
  A_Float v   -> Array ArrFloat $ toArray v
  A_V2F   v   -> Array ArrFloat $ toArray v
  A_V3F   v   -> Array ArrFloat $ toArray v
  A_V4F   v   -> Array ArrFloat $ toArray v
  A_M22F  v   -> Array ArrFloat $ toArray v
  A_M33F  v   -> Array ArrFloat $ toArray v
  A_M44F  v   -> Array ArrFloat $ toArray v
  _ -> unsafeCrashWith "meshAttrToArray - unsupported MeshAttribute"
{-
  A_Flat _ v  -> Array ArrFloat v
-}
meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
meshAttrToStream b i a = Stream $ case a of
  A_Float v   -> {sType: TFloat, buffer: b, arrIdx: i , start: 0, length: length v}
  A_V2F   v   -> {sType: TV2F  , buffer: b, arrIdx: i , start: 0, length: length v}
  A_V3F   v   -> {sType: TV3F  , buffer: b, arrIdx: i , start: 0, length: length v}
  A_V4F   v   -> {sType: TV4F  , buffer: b, arrIdx: i , start: 0, length: length v}
  A_M22F  v   -> {sType: TM22F , buffer: b, arrIdx: i , start: 0, length: length v}
  A_M33F  v   -> {sType: TM33F , buffer: b, arrIdx: i , start: 0, length: length v}
  A_M44F  v   -> {sType: TM44F , buffer: b, arrIdx: i , start: 0, length: length v}
  _ -> unsafeCrashWith "meshAttrToStream - unsupported MeshAttribute"
{-
  A_Flat t v  -> let
      tn = case t of
        AT_Float  -> Tuple TFloat 1
        AT_V2F    -> Tuple TV2F   2
        AT_V3F    -> Tuple TV3F   3
        AT_V4F    -> Tuple TV4F   4
        AT_M22F   -> Tuple TM22F  4
        AT_M33F   -> Tuple TM33F  9
        AT_M44F   -> Tuple TM44F  16
    in case tn of
      Tuple st n -> {sType: st , buffer: b, arrIdx: i , start: 0, length: length v / n}
-}

module LambdaCube.WebGL.Mesh where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Data.StrMap as StrMap
import Data.Maybe
import Data.Maybe (fromJust)
import Data.Array
import Data.Tuple
import Data.Int
import Data.List as List

import Data.Argonaut.Encode.Combinators ((~>), (:=))
import Data.Argonaut.Decode.Combinators ((.?))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Encode (class EncodeJson, encodeJson)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Partial.Unsafe (unsafeCrashWith, unsafePartial)

import LambdaCube.IR
import LambdaCube.LinearBase
import LambdaCube.WebGL.Type
import LambdaCube.WebGL.Data
import LambdaCube.WebGL.Input

data AttributeType
    = AT_Float
    | AT_V2F
    | AT_V3F
    | AT_V4F
    | AT_M22F
    | AT_M33F
    | AT_M44F

data MeshAttribute
    = A_Float   (Array Float)
    | A_V2F     (Array V2F)
    | A_V3F     (Array V3F)
    | A_V4F     (Array V4F)
    | A_M22F    (Array M22F)
    | A_M33F    (Array M33F)
    | A_M44F    (Array M44F)
    | A_Flat    AttributeType (Array Float)

data MeshPrimitive
    = P_Points
    | P_TriangleStrip
    | P_Triangles
    | P_TriangleStripI  (Array Word16)
    | P_TrianglesI      (Array Word16)

data Mesh = Mesh
    { attributes  :: StrMap.StrMap MeshAttribute
    , primitive   :: MeshPrimitive
    , gpuData     :: Maybe GPUData
    }

type GPUData =
    { primitive :: Primitive
    , streams   :: StrMap.StrMap (Stream Buffer)
    , indices   :: Maybe (IndexStream Buffer)
    }

addMesh :: WebGLPipelineInput -> String -> Mesh -> Array String -> GFX GLObject
addMesh input slotName (Mesh mesh) objUniNames = case mesh.gpuData of
  Nothing -> throwException $ error "addMesh: only compiled mesh with GPUData is supported"
  Just g -> case StrMap.lookup slotName input.schema.slots of
    Nothing -> throwException $ error "addMesh: slot not found"
    Just slotSchema -> do
      -- select proper attributes
      let filterStream (Tuple n s) = StrMap.member n slotSchema.attributes
      addObject input slotName g.primitive g.indices (StrMap.fromFoldable $ List.filter filterStream $ StrMap.toList g.streams) objUniNames

compileMesh :: Mesh -> GFX Mesh
compileMesh (Mesh mesh) = unsafePartial $ case mesh.gpuData of
  Just _ -> pure $ Mesh mesh
  Nothing -> do
    let mkIndexBuf v = do
            iBuf <- compileBuffer [Array ArrWord16 (toArray v)]
            pure $ Just {buffer: iBuf, arrIdx: 0, start: 0, length: length v}
    vBuf <- compileBuffer $ map meshAttrToArray $ List.toUnfoldable (StrMap.values mesh.attributes)
    Tuple prim indices <- case mesh.primitive of
        P_Points            -> pure $ Tuple PointList     Nothing
        P_TriangleStrip     -> pure $ Tuple TriangleStrip Nothing
        P_Triangles         -> pure $ Tuple TriangleList  Nothing
        P_TriangleStripI v  -> Tuple TriangleStrip <$> mkIndexBuf v
        P_TrianglesI v      -> Tuple TriangleList <$> mkIndexBuf v
    let streams = StrMap.fromFoldable $ List.zipWith (\i (Tuple n a) -> Tuple n (meshAttrToStream vBuf i a)) (List.range 0 $ fromJust $ fromNumber $ StrMap.size mesh.attributes) (StrMap.toList mesh.attributes)
        gpuData = {primitive: prim, streams: streams, indices: indices}
    pure $ Mesh $ mesh {gpuData = Just gpuData}

meshAttrToArray :: MeshAttribute -> LCArray
meshAttrToArray a = case a of
  A_Float v   -> Array ArrFloat $ toArray v
  A_V2F   v   -> Array ArrFloat $ toArray v
  A_V3F   v   -> Array ArrFloat $ toArray v
  A_V4F   v   -> Array ArrFloat $ toArray v
  A_M22F  v   -> Array ArrFloat $ toArray v
  A_M33F  v   -> Array ArrFloat $ toArray v
  A_M44F  v   -> Array ArrFloat $ toArray v
  A_Flat _ v  -> Array ArrFloat v

meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
meshAttrToStream b i a = Stream $ case a of
  A_Float v   -> {sType: TFloat, buffer: b, arrIdx: i , start: 0, length: length v}
  A_V2F   v   -> {sType: TV2F  , buffer: b, arrIdx: i , start: 0, length: length v}
  A_V3F   v   -> {sType: TV3F  , buffer: b, arrIdx: i , start: 0, length: length v}
  A_V4F   v   -> {sType: TV4F  , buffer: b, arrIdx: i , start: 0, length: length v}
  A_M22F  v   -> {sType: TM22F , buffer: b, arrIdx: i , start: 0, length: length v}
  A_M33F  v   -> {sType: TM33F , buffer: b, arrIdx: i , start: 0, length: length v}
  A_M44F  v   -> {sType: TM44F , buffer: b, arrIdx: i , start: 0, length: length v}
  A_Flat t v  -> let
      tn = case t of
        AT_Float  -> Tuple TFloat 1
        AT_V2F    -> Tuple TV2F   2
        AT_V3F    -> Tuple TV3F   3
        AT_V4F    -> Tuple TV4F   4
        AT_M22F   -> Tuple TM22F  4
        AT_M33F   -> Tuple TM33F  9
        AT_M44F   -> Tuple TM44F  16
    in case tn of
      Tuple st n -> {sType: st , buffer: b, arrIdx: i , start: 0, length: length v / n}

instance decodeJsonMeshPrimitive :: DecodeJson MeshPrimitive where
  decodeJson json = do
    obj <- decodeJson json
    tag <- obj .? "tag"
    case tag of
      "P_Points"          -> pure P_Points
      "P_TriangleStrip"   -> pure P_TriangleStrip
      "P_Triangles"       -> pure P_Triangles
      "P_TriangleStripI"  -> P_TriangleStripI <$> obj .? "values"
      "P_TrianglesI"      -> P_TrianglesI <$> obj .? "values"
      _ -> unsafeCrashWith "decodeJson @ MeshPrimitive"

instance decodeJsonMeshAttribute :: DecodeJson MeshAttribute where
  decodeJson json = do
    obj <- decodeJson json
    tag <- obj .? "tag"
    case tag of
      "A_Float" -> A_Flat AT_Float <$> obj .? "values"
      "A_V2F"   -> A_Flat AT_V2F   <$> obj .? "values"
      "A_V3F"   -> A_Flat AT_V3F   <$> obj .? "values"
      "A_V4F"   -> A_Flat AT_V4F   <$> obj .? "values"
      "A_M22F"  -> A_Flat AT_M22F  <$> obj .? "values"
      "A_M33F"  -> A_Flat AT_M33F  <$> obj .? "values"
      "A_M44F"  -> A_Flat AT_M44F  <$> obj .? "values"
      _ -> unsafeCrashWith "decodeJson @ MeshAttribute"

instance decodeJsonMesh :: DecodeJson Mesh where
  decodeJson json = do
    obj <- decodeJson json
    attributes <- obj .? "attributes"
    primitive <- obj .? "primitive"
    pure $ Mesh {attributes:attributes,primitive:primitive,gpuData:Nothing}


Elm encoder compiles, not tested yet

Elm encoder compiles, not tested yet

Original commit 089d4742036762d985d55be40fa821bc3a4a2c9b

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List)
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (sortByKey, sortByKeyM, forEnumerated_)

forbiddenWords :: Array String
forbiddenWords =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "root", "encodeRoot"
    , "jenc", "jdec", "jpipe"
    , "always", "identity"
    , "array", "dict", "maybe"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenWords

forbiddenNames :: Array String
forbiddenNames = A.insert "Root" $ map capitalize forbiddenWords

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        }
    }

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

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

legalizeIdentifier :: Boolean -> String -> String
legalizeIdentifier upper str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier upper ((if upper then "F_" else "f_") <> str)

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    line """module QuickType exposing (Root, root, encodeRoot)

import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array
import Dict

array__enc : (a -> Jenc.Value) -> Array.Array a -> Jenc.Value
array__enc f arr =
    Jenc.array (Array.map f arr)

dict__enc : (a -> Jenc.Value) -> Dict.Dict String a -> Jenc.Value
dict__enc f dict =
    Jenc.object (Dict.toList (Dict.map (\k -> f) dict))

nullable__enc : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
nullable__enc f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered, comment: topLevelComment } <- typeStringForType topLevel
    line $ "type alias Root = " <> topLevelRendered <> renderComment topLevelComment
    blank
    rootDecoder <- decoderNameForType topLevel
    line "root : Jdec.Decoder Root"
    line $ "root = " <> rootDecoder
    blank
    rootEncoder <- encoderNameForType topLevel
    line "encodeRoot : Root -> String"
    line $ "encodeRoot r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        blank
        renderTypeDefinition i cls
    unions <- getUnions
    for_ unions \types -> do
        blank
        renderUnionDefinition types

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

typeStringForUnion :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
typeStringForUnion s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- typeStringForType x
        pure { rendered: "(Maybe " <> rendered <> ")", comment: Just $ maybe "optional" ("optional " <> _) comment }
    Nothing -> do
        noComment =<< lookupUnionName s

typeStringForType :: IRType -> Doc { rendered :: String, comment :: Maybe String }
typeStringForType = case _ of
    IRNothing -> noComment "Jdec.Value"
    IRNull -> noComment "()"
    IRInteger -> noComment "Int"
    IRDouble -> noComment "Float"
    IRBool -> noComment "Bool"
    IRString -> noComment "String"
    IRArray a -> do
        { rendered, comment } <- typeStringForType a
        pure { rendered: "(Array.Array " <> rendered <> ")", comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- typeStringForType t
        pure { rendered: "(Dict.Dict String " <> rendered <> ")", comment: map ("map to " <> _) comment }
    IRUnion types -> typeStringForUnion $ unionToSet types

lookupClassDecoderName :: Int -> Doc String
lookupClassDecoderName i = decapitalize <$> lookupClassName i

lookupUnionDecoderName :: Set IRType -> Doc String
lookupUnionDecoderName s = decapitalize <$> lookupUnionName s

encoderNameFromDecoderName :: String -> String
encoderNameFromDecoderName decoderName = "enc__" <> decoderName

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc String
decoderNameForType = case _ of
    IRNothing -> pure "Jdec.value"
    IRNull -> pure "(Jdec.null ())"
    IRInteger -> pure "Jdec.int"
    IRDouble -> pure "Jdec.float"
    IRBool -> pure "Jdec.bool"
    IRString -> pure "Jdec.string"
    IRArray a -> do
        rendered <- decoderNameForType a
        pure $ "(Jdec.array " <> rendered <> ")"
    IRClass i -> lookupClassDecoderName i
    IRMap t -> do
        rendered <- decoderNameForType t
        pure $ "(Jdec.dict " <> rendered <> ")"
    IRUnion types ->
        case nullableFromSet $ unionToSet types of
        Just t -> do
            rendered <- decoderNameForType t
            pure $ "(Jdec.nullable " <> rendered <> ")"
        Nothing -> do
            lookupUnionDecoderName $ unionToSet types

encoderNameForType :: IRType -> Doc String
encoderNameForType = case _ of
    IRNothing -> pure "identity"
    IRNull -> pure "(always Jenc.null)"
    IRInteger -> pure $ "Jenc.int"
    IRDouble -> pure $ "Jenc.float"
    IRBool -> pure $ "Jenc.bool"
    IRString -> pure $ "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        pure $ "(array__enc " <> rendered <> ")"
    IRClass i -> encoderNameFromDecoderName <$> lookupClassDecoderName i
    IRMap t -> do
        rendered <- encoderNameForType t
        pure $ "(dict__enc " <> rendered <> ")"
    IRUnion types ->
        case nullableFromSet $ unionToSet types of
        Just t -> do
            rendered <- encoderNameForType t
            pure $ "(nullable__enc " <> rendered <> ")"
        Nothing ->
            encoderNameFromDecoderName <$> (lookupUnionDecoderName $ unionToSet types)

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> IRClassData -> Doc Unit
renderTypeDefinition classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames lowerNameStyle (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered, comment } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered <> renderComment comment
        when (propsList == L.Nil) do
            line "{"
        line "}"
    blank
    decoderName <- lookupClassDecoderName classIndex
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> propDecoder <> fallback
    blank
    let encoderName = encoderNameFromDecoderName decoderName
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                propEncoder <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
        when (propsList == L.Nil) do
            line "["
        line "]"

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    name <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> name
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                { rendered, comment } <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> rendered <> renderComment comment
    blank
    decoderName <- lookupUnionDecoderName allTypes
    line $ decoderName <> " : Jdec.Decoder " <> name
    line $ decoderName <> " ="
    indent do
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ fields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> decoder
            line "]"
    blank
    let encoderName = encoderNameFromDecoderName decoderName
    line $ encoderName <> " : " <> name <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                encoder <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List)
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (sortByKey, sortByKeyM, forEnumerated_)

forbiddenWords :: Array String
forbiddenWords =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "root", "jenc", "jdec", "jpipe", "array", "dict", "maybe"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenWords

forbiddenNames :: Array String
forbiddenNames = A.insert "Root" $ map capitalize forbiddenWords

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        }
    }

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

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

legalizeIdentifier :: Boolean -> String -> String
legalizeIdentifier upper str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier upper ((if upper then "F_" else "f_") <> str)

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    line """module QuickType exposing (Root, root)

import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Array exposing (Array)
import Dict exposing (Dict)
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered, comment: topLevelComment } <- typeStringForType topLevel
    line $ "type alias Root = " <> topLevelRendered <> renderComment topLevelComment
    blank
    line "root : Jdec.Decoder Root"
    rootDecoder <- decoderNameForType topLevel
    line $ "root = " <> rootDecoder
    blank
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderTypeDefinition i cls
        blank
    unions <- getUnions
    for_ unions \types -> do
        blank
        renderUnionDefinition types

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

typeStringForUnion :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
typeStringForUnion s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- typeStringForType x
        pure { rendered: "(Maybe " <> rendered <> ")", comment: Just $ maybe "optional" ("optional " <> _) comment }
    Nothing -> do
        noComment =<< lookupUnionName s

typeStringForType :: IRType -> Doc { rendered :: String, comment :: Maybe String }
typeStringForType = case _ of
    IRNothing -> noComment "Jdec.Value"
    IRNull -> noComment "()"
    IRInteger -> noComment "Int"
    IRDouble -> noComment "Float"
    IRBool -> noComment "Bool"
    IRString -> noComment "String"
    IRArray a -> do
        { rendered, comment } <- typeStringForType a
        pure { rendered: "(Array " <> rendered <> ")", comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- typeStringForType t
        pure { rendered: "(Dict String " <> rendered <> ")", comment: map ("map to " <> _) comment }
    IRUnion types -> typeStringForUnion $ unionToSet types

lookupClassDecoderName :: Int -> Doc String
lookupClassDecoderName i = decapitalize <$> lookupClassName i

lookupUnionDecoderName :: Set IRType -> Doc String
lookupUnionDecoderName s = decapitalize <$> lookupUnionName s

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc String
decoderNameForType = case _ of
    IRNothing -> pure "Jdec.value"
    IRNull -> pure "(Jdec.null ())"
    IRInteger -> pure "Jdec.int"
    IRDouble -> pure "Jdec.float"
    IRBool -> pure "Jdec.bool"
    IRString -> pure "Jdec.string"
    IRArray a -> do
        rendered <- decoderNameForType a
        pure $ "(Jdec.array " <> rendered <> ")"
    IRClass i -> lookupClassDecoderName i
    IRMap t -> do
        rendered <- decoderNameForType t
        pure $ "(Jdec.dict " <> rendered <> ")"
    IRUnion types ->
        case nullableFromSet $ unionToSet types of
        Just t -> do
            rendered <- decoderNameForType t
            pure $ "(Jdec.nullable " <> rendered <> ")"
        Nothing -> do
            lookupUnionDecoderName $ unionToSet types

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> IRClassData -> Doc Unit
renderTypeDefinition classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames lowerNameStyle (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered, comment } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered <> renderComment comment
        when (propsList == L.Nil) do
            line "{"
        line "}"
    blank
    decoderName <- lookupClassDecoderName classIndex
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                decoderName <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> decoderName <> fallback

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    name <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> name
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                { rendered, comment } <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> rendered <> renderComment comment
    blank
    decoderName <- lookupUnionDecoderName allTypes
    line $ decoderName <> " : Jdec.Decoder " <> name
    line $ decoderName <> " ="
    indent do
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ fields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> decoder
            line "]"


Add expression type field to div tree

Add expression type field to div tree

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (TypeTree, Tree(..), Binding(..), TypedBinding(..), Atom(..), Op, pPrintOp, TypeQual, QualTree(..), MType, Type, prettyPrintType, prettyPrintTypeError)

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)), exprType :: MType }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: Nothing
    }
    (fromFoldable children)

typedNodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> TypeTree -> (TypeTree -> TypeTree) -> Div
typedNodeHole content classes children exprType expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: exprType
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: Nothing
    }
    (fromFoldable children)

typedNode :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> Div
typedNode content classes children exprType =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: exprType
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom t a)            = atom t a
    go hole expr@(List t ls)           = case toString ls of
                                           Nothing  -> list t (zipList go (hole <<< List Nothing) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] t
    go hole expr@(NTuple t ls)         = ntuple t (zipList go (hole <<< NTuple Nothing) ls) expr hole
    go hole expr@(Binary _ op_tup@(Tuple op t) e1 e2)   = binary t op
                                           (go (\e1 -> hole $ Binary Nothing op_tup e1 e2) e1)
                                           (go (\e2 -> hole $ Binary Nothing op_tup e1 e2) e2)
                                           expr hole
    go hole expr@(Unary t op e)        = unary t (unpackOp op) (go (hole <<< Unary Nothing op) e) expr hole
    go hole expr@(SectL t e op)        = sectl t (go (\e -> hole $ SectL Nothing e op) e) (unpackOp op) expr hole
    go hole expr@(SectR t op e)        = sectr t (unpackOp op) (go (hole <<< SectR Nothing op) e) expr hole
    go hole      (PrefixOp t op)       = prefixOp t (unpackOp op)
    go hole expr@(IfExpr t ce te ee)   = ifexpr t
                                           (go (\ce -> hole $ IfExpr Nothing ce te ee) ce)
                                           (go (\te -> hole $ IfExpr Nothing ce te ee) te)
                                           (go (\ee -> hole $ IfExpr Nothing ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr t bes body)  = letexpr t
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr Nothing xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr Nothing bes x) body)
                                           expr hole
    go hole expr@(Lambda t binds body) = lambda t (binding <$> binds) (go (hole <<< Lambda Nothing binds) body) expr hole

    go hole expr@(ArithmSeq t start next end)
                                       = arithmseq t
                                           (go (\x -> hole $ ArithmSeq Nothing x next end) start)
                                           (go (\x -> hole $ ArithmSeq Nothing start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq Nothing start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp t e qs)     = listcomp t
                                           (go (\x -> hole $ ListComp Nothing x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp Nothing e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard t e) = guardQual t           (go (\x -> hole $ Guard Nothing x) e)
        qualToDiv hole (Let t b e) = letQual t (binding b) (go (\x -> hole $ Let Nothing b x) e)
        qualToDiv hole (Gen t b e) = genQual t (binding b) (go (\x -> hole $ Gen Nothing b x) e)

    go hole expr@(App t func args) = app t (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App Nothing func args
        argsDivs = zipList go (hole <<< App Nothing func) args

guardQual :: MType -> Div -> Div
guardQual t guard = typedNode "" ["guard"] [guard] t

letQual :: MType -> Div -> Div -> Div
letQual t bind expr = typedNode "" ["let"] [letDiv, bind, eqDiv, expr] t
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: MType -> Div -> Div -> Div
genQual t bind expr = typedNode "" ["gen"] [bind, arrow, expr] t
  where
    arrow = node "<-" ["comma"] []

atom :: MType -> Atom -> Div
atom t (AInt n) = typedNode (show n) ["atom", "num"] [] t
atom t (Bool b) = typedNode (if b then "True" else "False") ["atom", "bool"] [] t
atom t (Char c) = typedNode ("'" <> c <> "'") ["atom", "char"] [] t
atom t (Name n) = typedNode n ["atom", "name"] [] t

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: MType -> List Div -> DivHole
list t Nil = typedNodeHole "[]" ["list empty"] [] t
list t ls  = typedNodeHole "" ["list"] (listify "[" "," "]" ls) t

ntuple :: MType -> List Div -> DivHole
ntuple t ls = typedNodeHole "" ["tuple"] (listify "(" "," ")" ls) t

unpackOp :: Tuple Op MType -> Op
unpackOp (Tuple op _) = op

opToDiv :: MType -> Op -> Div
opToDiv t op = typedNode (pPrintOp op) ["op"] [] t

binary :: MType -> Op -> Div -> Div -> DivHole
binary t op d1 d2 = typedNodeHole "" ["binary"] [d1, opToDiv t op, d2] t

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: MType -> Op -> Div -> DivHole
unary t op div = nodeHole "" ["unary"] [openBrace, opToDiv t op, div, closeBrace]

sectl :: MType -> Div -> Op -> DivHole
sectl t div op = nodeHole "" ["section"] [openBrace, div, opToDiv t op, closeBrace]

sectr :: MType -> Op -> Div -> DivHole
sectr t op div = nodeHole "" ["section"] [openBrace, opToDiv t op, div, closeBrace]

prefixOp :: MType -> Op -> Div
prefixOp t op = node "" ["prefixOp"] [openBrace, opToDiv t op, closeBrace]

ifexpr :: MType -> Div -> Div -> Div -> DivHole
ifexpr t cd td ed = typedNodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed] t
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: MType -> List (Tuple Div Div) -> Div -> DivHole
letexpr t binds expr = typedNodeHole "" ["letexpr"] ([letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]) t
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: MType -> Div -> List Div -> DivHole
listcomp t expr quals = typedNodeHole "" ["listcomp", "list"] ([open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]) t
  where
    open  = node "[" ["brace"] []
    close = node "]" ["brace"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: MType -> List Div -> Div -> DivHole
lambda t params body = typedNodeHole "" ["lambda"] (open : bslash : params <> (arrow : body : close : Nil)) t
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: MType -> Div -> List Div -> DivHole
app t func args = typedNodeHole "" ["app"] (Cons func args) t

arithmseq :: MType -> Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq t start mnext mend = typedNodeHole "" ["arithmseq", "list"] ([open, start] <> commaNext <> [dots] <> end <> [close]) t
 where
    open      = node "[" ["brace"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots"] []
    end       = fromMaybe mend
    close     = node "]" ["brace"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = node "" ["binding", "lit"] [atom t a]
binding (ConsLit _ b1 b2) = node "" ["binding", "conslit"] $ listify "(" ":" ")" (Cons (binding b1) (Cons (binding b2) Nil))
binding (ListLit _ ls)    = node "" ["binding", "listlit"] $ listify "[" "," "]" (binding <$> ls)
binding (NTupleLit _ ls)   = node "" ["binding", "tuplelit"] $ listify "(" "," ")" (binding <$> ls)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM | eff) Unit)

divToJQuery :: forall eff. Callback -> Div -> Eff (dom :: DOM | eff) J.JQuery
divToJQuery callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  div <- makeDiv content classes
  for children (divToJQuery callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit
  pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (TypeTree, Tree(..), Binding(..), Atom(..), Op, pPrintOp, TypeQual, QualTree(..), MType)

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)) }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom _ a)            = atom a
    go hole expr@(List _ ls)           = case toString ls of
                                           Nothing  -> list (zipList go (hole <<< List Nothing) ls) expr hole
                                           Just str -> node ("\"" <> str <> "\"") ["list", "string"] []
    go hole expr@(NTuple _ ls)         = ntuple (zipList go (hole <<< NTuple Nothing) ls) expr hole
    go hole expr@(Binary _ op e1 e2)   = binary (unpackOp op)
                                           (go (\e1 -> hole $ Binary Nothing op e1 e2) e1)
                                           (go (\e2 -> hole $ Binary Nothing op e1 e2) e2)
                                           expr hole
    go hole expr@(Unary _ op e)        = unary (unpackOp op) (go (hole <<< Unary Nothing op) e) expr hole
    go hole expr@(SectL _ e op)        = sectl (go (\e -> hole $ SectL Nothing e op) e) (unpackOp op) expr hole
    go hole expr@(SectR _ op e)        = sectr (unpackOp op) (go (hole <<< SectR Nothing op) e) expr hole
    go hole      (PrefixOp _ op)       = prefixOp (unpackOp op)
    go hole expr@(IfExpr _ ce te ee)   = ifexpr
                                           (go (\ce -> hole $ IfExpr Nothing ce te ee) ce)
                                           (go (\te -> hole $ IfExpr Nothing ce te ee) te)
                                           (go (\ee -> hole $ IfExpr Nothing ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr _ bes body)  = letexpr
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr Nothing xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr Nothing bes x) body)
                                           expr hole
    go hole expr@(Lambda _ binds body) = lambda (binding <$> binds) (go (hole <<< Lambda Nothing binds) body) expr hole

    go hole expr@(ArithmSeq _ start next end)
                                       = arithmseq
                                           (go (\x -> hole $ ArithmSeq Nothing x next end) start)
                                           (go (\x -> hole $ ArithmSeq Nothing start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq Nothing start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp _ e qs)     = listcomp
                                           (go (\x -> hole $ ListComp Nothing x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp Nothing e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard _ e) = guardQual           (go (\x -> hole $ Guard Nothing x) e)
        qualToDiv hole (Let _ b e) = letQual (binding b) (go (\x -> hole $ Let Nothing b x) e)
        qualToDiv hole (Gen _ b e) = genQual (binding b) (go (\x -> hole $ Gen Nothing b x) e)

    go hole expr@(App _ func args)     = app (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App Nothing func args
        argsDivs = zipList go (hole <<< App Nothing func) args

guardQual :: Div -> Div
guardQual guard = node "" ["guard"] [guard]

letQual :: Div -> Div -> Div
letQual bind expr = node "" ["let"] [letDiv, bind, eqDiv, expr]
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: Div -> Div -> Div
genQual bind expr = node "" ["gen"] [bind, arrow, expr]
  where
    arrow = node "<-" ["comma"] []

atom :: Atom -> Div
atom (AInt n) = node (show n) ["atom", "num"] []
atom (Bool b) = node (if b then "True" else "False") ["atom", "bool"] []
atom (Char c) = node ("'" <> c <> "'") ["atom", "char"] []
atom (Name n) = node n ["atom", "name"] []

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: List Div -> DivHole
list Nil = nodeHole "[]" ["list empty"] []
list ls  = nodeHole "" ["list"] $ listify "[" "," "]" ls

ntuple :: List Div -> DivHole
ntuple ls = nodeHole "" ["tuple"] $ listify "(" "," ")" ls

unpackOp :: Tuple Op MType -> Op
unpackOp (Tuple op _) = op

opToDiv :: Op -> Div
opToDiv op = node (pPrintOp op) ["op"] []

binary :: Op -> Div -> Div -> DivHole
binary op d1 d2 = nodeHole "" ["binary"] [d1, opToDiv op, d2]

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: Op -> Div -> DivHole
unary op div = nodeHole "" ["unary"] [openBrace, opToDiv op, div, closeBrace]

sectl :: Div -> Op -> DivHole
sectl div op = nodeHole "" ["section"] [openBrace, div, opToDiv op, closeBrace]

sectr :: Op -> Div -> DivHole
sectr op div = nodeHole "" ["section"] [openBrace, opToDiv op, div, closeBrace]

prefixOp :: Op -> Div
prefixOp op = node "" ["prefixOp"] [openBrace, opToDiv op, closeBrace]

ifexpr :: Div -> Div -> Div -> DivHole
ifexpr cd td ed = nodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed]
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: List (Tuple Div Div) -> Div -> DivHole
letexpr binds expr = nodeHole "" ["letexpr"] $ [letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: Div -> List Div -> DivHole
listcomp expr quals = nodeHole "" ["listcomp", "list"] $ [open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]
  where
    open  = node "[" ["brace"] []
    close = node "]" ["brace"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: List Div -> Div -> DivHole
lambda params body = nodeHole "" ["lambda"] (Cons open (Cons bslash (params <> (Cons arrow (Cons body (Cons close Nil))))))
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: Div -> List Div -> DivHole
app func args = nodeHole "" ["app"] (Cons func args)

arithmseq :: Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq start mnext mend = nodeHole "" ["arithmseq", "list"] $ [open, start] <> commaNext <> [dots] <> end <> [close]
 where
    open      = node "[" ["brace"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots"] []
    end       = fromMaybe mend
    close     = node "]" ["brace"] []

binding :: forall a. Binding a -> Div
binding (Lit _ a)         = node "" ["binding", "lit"] [atom a]
binding (ConsLit _ b1 b2) = node "" ["binding", "conslit"] $ listify "(" ":" ")" (Cons (binding b1) (Cons (binding b2) Nil))
binding (ListLit _ ls)    = node "" ["binding", "listlit"] $ listify "[" "," "]" (binding <$> ls)
binding (NTupleLit _ ls)   = node "" ["binding", "tuplelit"] $ listify "(" "," ")" (binding <$> ls)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM | eff) Unit)

divToJQuery :: forall eff. Callback -> Div -> Eff (dom :: DOM | eff) J.JQuery
divToJQuery callback (Node { content: content, classes: classes, zipper: zipper } children) = do
  div <- makeDiv content classes
  for children (divToJQuery callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit
  pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d


Refactor 'getValue' to explicitly use 'unsafe'

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Data.Either
import Data.Maybe
import Control.Apply ((*>))

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff a = forall eff. Eff (dom :: DOM, trace :: Trace | eff) a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  showExpr env expr

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: forall eff. (J.JQuery -> Eff (dom :: DOM | eff) Unit) -> J.JQuery -> Eff (dom :: DOM | eff) Unit

showExpr :: forall eff. Env -> Expr -> DOMEff Unit
showExpr env expr = do
  outputContainer <- J.select "#output-container"
  J.clear outputContainer

  output <- J.create "

" >>= J.addClass "output"
  J.append output outputContainer

  jexpr <- exprToJQuery expr
  J.append jexpr output

  J.find ".binary, .app, .func" output >>= map (makeClickable env expr)
  J.find ".clickable" output >>= addMouseOverListener >>= addClickListener env expr
  J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver)

  return unit

makeClickable :: forall eff. Env -> Expr -> J.JQuery -> DOMEff Unit
makeClickable env expr jq = do
  path <- getPath jq
  case evalPath1 env path expr of
    Nothing -> return unit
    Just _  -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> DOMEff J.JQuery
addMouseOverListener jq = J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: Env -> Expr -> J.JQuery -> DOMEff J.JQuery
addClickListener env expr jq = J.on "click" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    evalExpr env path expr

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: forall eff. Env -> Path -> Expr -> DOMEff Unit
evalExpr env path expr =
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      showExpr env expr'

getValue :: forall eff. J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (readString)

import Data.Either
import Data.Maybe
import Control.Apply ((*>))

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff a = forall eff. Eff (dom :: DOM, trace :: Trace | eff) a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  showExpr env expr

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: forall eff. (J.JQuery -> Eff (dom :: DOM | eff) Unit) -> J.JQuery -> Eff (dom :: DOM | eff) Unit

showExpr :: forall eff. Env -> Expr -> DOMEff Unit
showExpr env expr = do
  outputContainer <- J.select "#output-container"
  J.clear outputContainer

  output <- J.create "

" >>= J.addClass "output"
  J.append output outputContainer

  jexpr <- exprToJQuery expr
  J.append jexpr output

  J.find ".binary, .app, .func" output >>= map (makeClickable env expr)
  J.find ".clickable" output >>= addMouseOverListener >>= addClickListener env expr
  J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver)

  return unit

makeClickable :: forall eff. Env -> Expr -> J.JQuery -> DOMEff Unit
makeClickable env expr jq = do
  path <- getPath jq
  case evalPath1 env path expr of
    Nothing -> return unit
    Just _  -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> DOMEff J.JQuery
addMouseOverListener jq = J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: Env -> Expr -> J.JQuery -> DOMEff J.JQuery
addClickListener env expr jq = J.on "click" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    evalExpr env path expr

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: forall eff. Env -> Path -> Expr -> DOMEff Unit
evalExpr env path expr =
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      showExpr env expr'

getValue :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) String
getValue j = do
  value <- J.getValue j
  case readString value of
    Right str -> return str


fixed Main file

fixed Main file

module Main where

import Prelude (Unit, (+), ($))
import Control.Monad.Eff (Eff)
import Projections (Projection, when, (+++), runProjection)

-- Example state type
type State = {count :: Int}

type TypA = {event :: String}

handlerA :: State -> TypA -> State
handlerA s e = {count: s.count+1}

handlerB :: State -> TypA -> State
handlerB s e = {count: s.count+1}

main :: forall t9. Eff ( eventFold :: Projection | t9) Unit
main = runProjection "Figo" {count:0} $ when "Hello" handlerA +++ when "Figo" handlerB

module Main where

import Prelude (Unit, (+), ($))
import Control.Monad.Eff (Eff)
import Purejections (EventFold, when, (+++), runProjection)

-- Example state type
type State = {count :: Int}

type NewStat = {event :: String}

handlerA :: State -> TypA -> State
handlerA s e = {count: s.count+1}

handlerB :: State -> TypB -> State
handlerB s e = {count: s.count+1}

main :: forall t9. Eff ( eventFold :: Projection | t9) Unit
main = runProjection "Figo" {count:0} $ when "Hello" handlerA +++ when "Figo" handlerB


Change Type name from `This` to `Self` to avoid confusing.

module Main where

import Control.Monad.Eff

foreign import data Vue :: *
foreign import data Self :: *

foreign import data Filter :: *
foreign import data Method :: !

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        return new Vue(opt);\
    \    }\
    \}" :: forall e r. { el :: String | r } -> Eff e Vue

foreign import truncate
    "function truncate(v) {\
    \    var newline = v.indexOf('\\n');\
    \    return newline > -1 ? v.slice(0, newline) : v;\
    \}" :: Filter

foreign import formatDate
    "function formatDate(v) {\
    \    return v.replace(/T|Z/g, ' ');\
    \}" :: Filter

foreign import fetchData
    "function fetchData(self) {\
    \    return function() {\
    \        var apiUrl = 'https://api.github.com/repos/yyx990803/vue/commits?per_page=3&sha=';\
    \        var xhr = new XMLHttpRequest();\
    \        xhr.open('GET', apiUrl + self.branch);\
    \        xhr.onload = function() {\
    \            self.commits = JSON.parse(xhr.responseText);\
    \        };\
    \        xhr.send();\
    \    };\
    \}" :: forall e. Self -> Eff e {}

foreign import method
    "function method(f) {\
    \    return function() {\
    \        var self = this;\
    \        return f(self)();\
    \    };\
    \}" :: forall r a. (Self -> Eff (method :: Method | r) a) -> Eff r a

-- TODO: need to factor out
foreign import callM
    "function callM(method) {\
    \    return function(key) {\
    \        return function(eff) {\
    \           return function(self) {\
    \               return function() {\
    \                   return self[method](key, eff(self));\
    \               };\
    \           };\
    \       };\
    \    };\
    \}" :: forall e a. String -> String -> (Self -> Eff e {}) -> (Self -> Eff (method :: Method | e) {})

watch = callM "$watch"

main = do
    vue
        {
            el: "#demo",
            dat: {
                branch: "master"
            },
            created: method (watch "branch" fetchData),
            filters: {
                truncate: truncate,
                formatDate: formatDate
            },
            methods: {
                fetchData: method fetchData
            }
        }

module Main where

import Control.Monad.Eff

foreign import data Vue :: *
foreign import data This :: *

foreign import data Filter :: *
foreign import data Method :: !

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        return new Vue(opt);\
    \    }\
    \}" :: forall e r. { el :: String | r } -> Eff e Vue

foreign import truncate
    "function truncate(v) {\
    \    var newline = v.indexOf('\\n');\
    \    return newline > -1 ? v.slice(0, newline) : v;\
    \}" :: Filter

foreign import formatDate
    "function formatDate(v) {\
    \    return v.replace(/T|Z/g, ' ');\
    \}" :: Filter

foreign import fetchData
    "function fetchData(self) {\
    \    return function() {\
    \        var apiUrl = 'https://api.github.com/repos/yyx990803/vue/commits?per_page=3&sha=';\
    \        var xhr = new XMLHttpRequest();\
    \        xhr.open('GET', apiUrl + self.branch);\
    \        xhr.onload = function() {\
    \            self.commits = JSON.parse(xhr.responseText);\
    \        };\
    \        xhr.send();\
    \    };\
    \}" :: forall e. This -> Eff e {}

foreign import method
    "function method(f) {\
    \    return function() {\
    \        var self = this;\
    \        return f(self)();\
    \    };\
    \}" :: forall r a. (This -> Eff (method :: Method | r) a) -> Eff r a

-- TODO: need to factor out
foreign import callM
    "function callM(method) {\
    \    return function(key) {\
    \        return function(eff) {\
    \           return function(self) {\
    \               return function() {\
    \                   return self[method](key, eff(self));\
    \               };\
    \           };\
    \       };\
    \    };\
    \}" :: forall e a. String -> String -> (This -> Eff e {}) -> (This -> Eff (method :: Method | e) {})

watch = callM "$watch"

main = do
    vue
        {
            el: "#demo",
            dat: {
                branch: "master"
            },
            created: method (watch "branch" fetchData),
            filters: {
                truncate: truncate,
                formatDate: formatDate
            },
            methods: {
--                fetchData: fetchData
            }
        }


[WIP]

[WIP]

module PSWC where

import Prelude

import Control.Monad.Aff (Aff, Fiber, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import CoreFn.FromJSON (moduleFromJSON)
import CoreFn.Module (Module(..))
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (guard)
import Data.Newtype (unwrap)
import Data.Path.Pathy (Dir, DirName(DirName), Path, Rel, Sandboxed, currentDir, dir, dir', file, parseRelFile, printPath, runDirName, sandbox, (<.>), (</>))
import Data.String as S
import Data.Traversable (traverse)
import Data.Trie (Trie(..), fromPaths)
import Data.Trie as Trie
import Debug.Trace (trace)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (exists, readTextFile, readdir, stat)
import Node.FS.Stats (isDirectory)
import Node.Path (FilePath)
import PureSwift.AST (AccessMod(..), Decl(..), DeclMod(..), Ident(..))
import PureSwift.PrettyPrinter (prettyPrint)

type Effects eff =
  ( fs :: FS
  , console :: CONSOLE
  | eff
  )

dryRun :: forall eff. Trie -> Array String -> Eff (console :: CONSOLE | eff) Unit
dryRun (Trie trie) ffis = do
  for_ trie \(Trie.Path path) ->
    case Array.unsnoc path of
      Just { init, last } -> do
        log $ "// " <> Array.intercalate "." path <> "__Namespace.swift"
        let
          enum = Enum (AccessModifier Public : Nil) (Ident last) Nil
          decl = if Array.null init then enum else Extension (AccessModifier Public : Nil) (Ident $ Array.intercalate "." init) (enum : Nil)
        log $ prettyPrint decl <> "\n"
      Nothing -> pure unit
  log $ Array.intercalate "\n" ffis

toPaths :: forall eff. Array FilePath -> Aff (Effects eff) ({ moduleNamePaths :: Array Trie.Path, ffis :: Array String })
toPaths = foldr acc (pure { moduleNamePaths: [], ffis: [] })
  where
    acc
      :: String
      -> Aff (Effects eff) ({ moduleNamePaths :: Array Trie.Path, ffis :: Array String })
      -> Aff (Effects eff) ({ moduleNamePaths :: Array Trie.Path, ffis :: Array String })
    acc filename state = do
      { moduleNamePaths, ffis } <- state
      let
        moduleDir :: Path Rel Dir Sandboxed
        moduleDir = dir' outputDir </> dir filename

        hidden :: Boolean
        hidden = maybe false (S.singleton >>> (_ == ".")) $ S.charAt 0 filename

        when
          :: Boolean
          -> Aff (Effects eff) ({ moduleNamePaths :: Array Trie.Path, ffis :: Array String })
          -> Aff (Effects eff) ({ moduleNamePaths :: Array Trie.Path, ffis :: Array String })
        when true m = m
        when false _ = state

        whenM
          :: Aff (Effects eff) Boolean
          -> Aff (Effects eff) ({ moduleNamePaths :: Array Trie.Path, ffis :: Array String })
          -> Aff (Effects eff) ({ moduleNamePaths :: Array Trie.Path, ffis :: Array String })
        whenM mb m = do
          b <- mb
          when b m

      when (not hidden) do
        stat <- stat $ printPath moduleDir

        when (isDirectory stat) do
          let filepath = printPath $ moduleDir </> file "corefn.json"
          trace ("------") \_ ->
          trace ("filepath" <> show filepath) \_ ->

          whenM (exists filepath) do
            -- moduleNamePaths' <- moduleNamePaths
            coreFn <- readTextFile UTF8 filepath
            case runExcept (moduleFromJSON coreFn) of
              Left e ->
                -- trace ("Left: " <> show e) \_->
                state
              Right { module: (Module module_) } -> do
                -- trace ("Right: " <> show module_.moduleForeign) \_ ->
                let
                  { moduleForeign, moduleName } = module_
                  hasForeign = not Array.null moduleForeign
                  ffiPath = if hasForeign then map (_ <.> "swift") (sandbox currentDir =<< parseRelFile (unwrap module_.modulePath)) else Nothing
                  foo = trace ("ffiPath: " <> show (map printPath ffiPath)) \_ -> unit

                ffi <- traverse (printPath >>> readTextFile UTF8) ffiPath
                let bar = trace ("ffi: " <> show ffi) \_ -> unit

                let
                  moduleNamePath = Trie.Path $ map unwrap $ unwrap moduleName
                  foreignNamePaths = guard hasForeign [moduleNamePath <> Trie.Path ["_Foreign"]]
                  namePaths = [moduleNamePath] <> foreignNamePaths

                pure $
                  { moduleNamePaths: namePaths <> moduleNamePaths
                  , ffis: (maybe [] Array.singleton ffi) <> ffis
                  }

outputDir :: DirName
outputDir = DirName "output"

-- pulp build -- --dump-corefn
main :: forall eff. Eff (Effects eff) (Fiber (Effects eff) Unit)
main = launchAff do
  files <- readdir $ runDirName outputDir
  { moduleNamePaths, ffis } <- toPaths files
  let trie = fromPaths moduleNamePaths
  liftEff $ dryRun trie ffis

module PSWC where

import Prelude

import Control.Monad.Aff (Aff, Fiber, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import CoreFn.FromJSON (moduleFromJSON)
import CoreFn.Module (Module(..))
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (guard)
import Data.Newtype (unwrap)
import Data.Path.Pathy (Dir, DirName(DirName), Path, Rel, Sandboxed, currentDir, dir, dir', file, parseRelFile, printPath, runDirName, sandbox, (<.>), (</>))
import Data.String as S
import Data.Trie (Trie(..), fromPaths)
import Data.Trie as Trie
import Debug.Trace (trace)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (exists, readTextFile, readdir, stat)
import Node.FS.Stats (isDirectory)
import Node.Path (FilePath)
import PureSwift.AST (AccessMod(..), Decl(..), DeclMod(..), Ident(..))
import PureSwift.PrettyPrinter (prettyPrint)

type Effects eff =
  ( fs :: FS
  , console :: CONSOLE
  | eff
  )

dryRun :: forall eff. Trie -> Eff (console :: CONSOLE | eff) Unit
dryRun (Trie trie) = for_ trie \(Trie.Path path) ->
  case Array.unsnoc path of
    Just { init, last } -> do
      log $ "// " <> Array.intercalate "." path <> "__Namespace.swift"
      let
        enum = Enum (AccessModifier Public : Nil) (Ident last) Nil
        decl = if Array.null init then enum else Extension (AccessModifier Public : Nil) (Ident $ Array.intercalate "." init) (enum : Nil)
      log $ prettyPrint decl <> "\n"
    Nothing -> pure unit

toPaths :: forall eff. Array FilePath -> Aff (Effects eff) (Array Trie.Path)
toPaths = foldr acc (pure [])
  where
    acc
      :: String
      -> Aff (Effects eff) (Array Trie.Path)
      -> Aff (Effects eff) (Array Trie.Path)
    acc filename moduleNamePaths = do
      let
        moduleDir :: Path Rel Dir Sandboxed
        moduleDir = dir' outputDir </> dir filename

        hidden :: Boolean
        hidden = maybe false (S.singleton >>> (_ == ".")) $ S.charAt 0 filename

        when
          :: Boolean
          -> Aff (Effects eff) (Array Trie.Path)
          -> Aff (Effects eff) (Array Trie.Path)
        when true m = m
        when false _ = moduleNamePaths

        whenM
          :: Aff (Effects eff) Boolean
          -> Aff (Effects eff) (Array Trie.Path)
          -> Aff (Effects eff) (Array Trie.Path)
        whenM mb m = do
          b <- mb
          when b m

      when (not hidden) do
        stat <- stat $ printPath moduleDir

        when (isDirectory stat) do
          let filepath = printPath $ moduleDir </> file "corefn.json"
          trace ("------") \_ ->
          trace ("filepath" <> show filepath) \_ ->

          whenM (exists filepath) do
            coreFn <- readTextFile UTF8 filepath
            case runExcept (moduleFromJSON coreFn) of
              Left e ->
                -- trace ("Left: " <> show e) \_->
                moduleNamePaths
              Right { module: (Module module_) } ->
                -- trace ("Right: " <> show module_.moduleForeign) \_ ->
                let
                  ffiPath = (_ <.> "swift") <$> (parseRelFile $ unwrap module_.modulePath)
                  foo = trace ("ffiPath: " <> show (map printPath (ffiPath >>= sandbox currentDir))) \_ -> unit
                -- let
                  { moduleForeign, moduleName } = module_
                  hasForeign = not Array.null moduleForeign
                  moduleNamePath = Trie.Path $ map unwrap $ unwrap moduleName
                  foreignNamePaths = guard hasForeign [moduleNamePath <> Trie.Path ["_Foreign"]]
                  namePaths = [moduleNamePath] <> foreignNamePaths
                in
                  pure namePaths <> moduleNamePaths

outputDir :: DirName
outputDir = DirName "output"

-- pulp build -- --dump-corefn
main :: forall eff. Eff (Effects eff) (Fiber (Effects eff) Unit)
main = launchAff do
  files <- readdir $ runDirName outputDir
  paths <- toPaths files
  let trie = fromPaths paths
  liftEff $ dryRun trie


all module exported

all module exported

module Blueprint
( module B
) where

-- TODO: Lets import all the modules and re-export them within this module
import Blueprint.Component.Alert (AlertProps, alert) as B
import Blueprint.Component.Breadcrum (BreadcrumProps, breadcrumb) as B
import Blueprint.Component.ButtonGroup (ButtonGroupModifier, buttonGroup, buttonGroupCustom, buttonGroupResponsive, buttonGroupVertical, fill, large, minimal, vertical) as B
import Blueprint.Component.Button (ButtonProps, anchorButton, button) as B
import Blueprint.Component.Callout (CalloutModifier, callout, withIcon) as B
import Blueprint.Component.Card (CardModifier, card, first, fourth, interactiveCard, second, third) as B
import Blueprint.Component.Collapse (CollapseProps, collapse) as B
import Blueprint.Component.CollapsibleList (CollapseForm, CollapsibleListProps, collapsibleList, end, start) as B
import Blueprint.Component.ContextMenu (contextMenuTarget) as B
import Blueprint.Component.Dialog (DialogProps, dialog) as B
import Blueprint.Component.EditableText (EditableTextProps, editableText) as B
import Blueprint.Component.FormControl (CheckboxProps, ControlPropsEx, IntOrString, NumericInputProps, RadioProps, SwitchProps, checkbox, numericInput, radio, radioGroup, switch) as B
import Blueprint.Component.Hotkeys (HotkeyProps, HotkeysProps, hotkey, hotkeys) as B
import Blueprint.Component.Menu (MenuDividerProps, MenuItemProps, MenuItemPropsEx, MenuProps, menu, menuDevider, menuItem) as B
import Blueprint.Component.Navbar (NavbarGroupModifier, NavbarModifier, navBar, navBarDivider, navBarFixed, navBarGroup) as B
import Blueprint.Component.NonIdealState (NonIdealStateProps, nonIdealState) as B
import Blueprint.Component.Overlay (OverLayableProps, OverLayablePropsEx, OverlayProps, OverlayPropsEx, overlay) as B
import Blueprint.Component.Popover (PopoverInteractionKind, PopoverProps, click, clickTargetOnly, hover, hoverTargetOnly, popover) as B
import Blueprint.Component.Portal (PortalProps, portal) as B
import Blueprint.Component.ProgressBar (ProgressBarProps, progressBar) as B
import Blueprint.Component.Slider (NumberRange, RenderLabel, SliderProps, SliderPropsEx, slider) as B
import Blueprint.Component.Spinner (SpinnerProps, spinner) as B
import Blueprint.Component.TableHtml (TableHtmlModifier(TableHtmlModifier), tableHtml, tableHtmlModifiers) as B
import Blueprint.Component.Tab (TabProps, TabPropsEx, tab) as B
import Blueprint.Component.Tag (TagProps, tag) as B
import Blueprint.Component.Toast (ActionOpt, ToastOptions, ToastProps, ToastPropsEx, toast, toaster) as B
import Blueprint.Component.Tooltip (TooltipProps, TooltipPropsEx, tooltip) as B
import Blueprint.Component.Tree (NumberORString, TreeProps, TreePropsEx, tree) as B

module Blueprint where

-- TODO: Lets import all the modules and re-export them within this module


withDispatch: rename

withDispatch: rename

module React.Redox
  ( ConnectState
  , withStore
  , connect'
  , connect
  , withDispatch
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..), fromJust, isJust)
import Data.Newtype (class Newtype, over)
import Partial.Unsafe (unsafePartial)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, createElement, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

foreign import forceUpdateImpl :: forall eff props state.
  EffFn1 eff (ReactThis props state) Unit

-- | Force render of a react component.
forceUpdate :: forall eff props state.
  ReactThis props state -> Eff eff Unit
forceUpdate this = runEffFn1 forceUpdateImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      when (isJust msid) do
        Redox.unsubscribe ctx.store (unsafePartial fromJust msid)

    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (unsafeCoerce props').children

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {store, dispatch: dispatch_})) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl

module React.Redox
  ( ConnectState
  , withStore
  , connect'
  , connect
  , connectToDispatch
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..), fromJust, isJust)
import Data.Newtype (class Newtype, over)
import Partial.Unsafe (unsafePartial)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, createElement, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

foreign import forceUpdateImpl :: forall eff props state.
  EffFn1 eff (ReactThis props state) Unit

-- | Force render of a react component.
forceUpdate :: forall eff props state.
  ReactThis props state -> Eff eff Unit
forceUpdate this = runEffFn1 forceUpdateImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      when (isJust msid) do
        Redox.unsubscribe ctx.store (unsafePartial fromJust msid)

    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

connectToDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectToDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (unsafeCoerce props').children

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {store, dispatch: dispatch_})) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl