Update tests for top-level [options] expansion

module Test.Spec.SolveSpec (solveSpec) where

import Prelude
import Debug.Trace
import Data.Either (Either(..), either, fromRight)
import Data.Pretty (pretty)
import Data.Tuple.Nested ((/\))
import Control.Bind ((=<<))
import Control.Apply ((*>))
import Data.List (List(..), fromFoldable)
import Data.Bifunctor (lmap, rmap)
import Control.Plus (empty)
import Data.Foldable (intercalate, for_)
import Data.Traversable (for)
import Control.Monad.Eff.Exception (error, throwException)
import Data.Array as A
import Data.Maybe (Maybe(..), maybe)
import Data.NonEmpty ((:|))
import Data.String as S

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Support (vliftEff, runEitherEff)

import Neodoc.Value
import Neodoc.Error.Class (capture) as Error
import Neodoc.Data.UsageLayout
import Neodoc.OptionAlias as OptionAlias
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.UsageLayout as Usage
import Neodoc.Spec (Spec (..))
import Neodoc.Spec.Lexer as Lexer
import Neodoc.Spec.Parser as SpecParser
import Neodoc.Spec.Parser.Usage as U
import Neodoc.Spec.Parser.Description as D
import Neodoc.Solve (solve)
import Neodoc.Solve.ExpandOptions (ExpandedOptionsLayoutArg(..), ExpandedOptionsLayout)
import Neodoc.Solve.Error (SolveError(..))
import Text.Wrap (dedent)
import Partial.Unsafe

-- | Since the solver only expands arguments, it's expanded version is valid
-- | usage input.
-- | For example: `-abc` expands to `-a -b -c`, which is valid input.
usageToSolved :: Partial => UsageLayout -> SolvedLayout
usageToSolved layout = layout <#> case _ of
  Usage.Command     n r        -> Solved.Command    n r
  Usage.Positional  n r        -> Solved.Positional n r
  Usage.Option      n a r      -> Solved.Option (OptionAlias.Long n) a r
  Usage.OptionStack (c:|_) a r -> Solved.Option (OptionAlias.Short c) a r
  Usage.EOA                    -> Solved.EOA
  Usage.Stdin                  -> Solved.Stdin

type Error = String
type Result = String
type UsageText = String
type DescriptionText = String
data TestSuite = TestSuite Boolean {- smart options? -} UsageText (Array TestCase)
data TestCase = TestCase DescriptionText (Either Error Result)

test = TestSuite false
testSmartOpts = TestSuite true

pass description expected = TestCase description (Right expected)
fail description err      = TestCase description (Left  err)

solveSpec = \_ ->
  describe "The solver" do
    for_ (fromFoldable [

      -- should not affect positionals and commands:
      test "prog foo"       [ pass "" "prog foo" ]
    , test "prog <prog>..." [ pass "" "prog <prog>..." ]

      -- options:
    , test "prog -io"
        [ pass "" "prog -i -o" ]

    , test "prog -io [-q]..."
        [ pass "" "prog -i -o [-q]..." ]

    , test "prog --foo..."
        [ fail "-f --foo=bar [default: qux]"
            "Option-Argument specified in options-section missing --foo" ]

    , test "prog --foo... BAR"
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo" ]

    , test "prog -f... BAR"
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f" ]

    , test "prog --foo BAR..."
        [ pass "-f --foo=BAR [default: qux]" "prog --foo=BAR..."
        , pass "-f --foo" "prog --foo BAR..." ]

    , test "prog --foo BAR"
        [ pass "-f --foo=BAR [default: qux]" "prog --foo=BAR"
        , pass "-f --foo" "prog --foo BAR" ]

    , test "prog --foo... BAR..."
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo" ]

    , test "prog -f... BAR..."
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f" ]

    , test "prog -xvzfFILE..."
        [ pass "-f --file=FILE [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog -xvzf=FILE..."
        [ pass "-f --file=FILE [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog -xvzf FILE..."
        [ pass "-f --file=FILE  [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog --file FILE..."
        [ fail
            """
            -f --file=FILE  [default: foo]
            -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file" ]

    , test "prog -f FILE..."
        [ fail
            """
            -f --file=FILE  [default: foo]
            -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option -f" ]

    , test "prog --file FILE..."
        [ fail
            """
            -f --file=FILE  [default: foo]
            -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file" ]

    , test "prog -fx..."
        [ fail
            "-f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments" ]

      -- Note: `f` should not adopt `file` as it's full name since it's in an
      -- option stack and not in trailing position (therefore cannot inherit the
      -- description's argument, rendering it an unfit candidate)
    , test "prog -fvzx..."
        [ fail
            "-f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments" ]

    , test "prog -xvzf FILE..."
        [ pass
            "-f --file=FILE  [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog -xvzf..."
        [ fail
            "-f --file=FILE  [default: foo]"
            "Option-Argument specified in options-section missing -f" ]

      -- same adjacent arg
    , test "prog -0 ARG ARG..."
        [ pass "-0, --foo ARG [default: 100]" "prog -0=ARG ARG..." ]

      -- optional arguments
    , test "prog -f"
        [ pass "-f[=ARG]" "prog -f[=ARG]" ]

    , test "prog --file"
        [ pass "--file[=ARG]" "prog --file[=ARG]" ]

      -- smart options
    , testSmartOpts "prog [-f FILE]"
        [ pass ""   "prog [-f=FILE]"
        , pass "-f" "prog [-f FILE]"
        ]

    , testSmartOpts "prog (-f FILE)"
        [ pass ""   "prog -f=FILE"
        , pass "-f" "prog (-f FILE)"
        ]

    , testSmartOpts     "prog [-a FOO] [-b BAR] [-c QUX]"
        [ pass ""       "prog [-a=FOO] [-b=BAR] [-c=QUX]"
        , fail "-a BAR" "Arguments mismatch for option -a: \"FOO\" and \"BAR\""
        ]

    , testSmartOpts "prog (-x <foo> | -f FILE)"
        [ pass ""                  "prog (-x=<foo> | -f=FILE)"
        , pass "-x"                "prog (-x <foo> | -f=FILE)"
        , pass "-f"                "prog (-x=<foo> | -f FILE)"
        , pass "-f\n-x"            "prog (-x <foo> | -f FILE)"
        , pass "-x=<foo>"          "prog (-x=<foo> | -f=FILE)"
        , pass "-f=FILE"           "prog (-x=<foo> | -f=FILE)"
        , pass "-f=FILE\n-x=<foo>" "prog (-x=<foo> | -f=FILE)"
        ]

      -- [references]:
    , test "prog [options]"
        [ pass
            """
            -a        Add
            -r        Remote
            -m <msg>  Message
            """
            "prog [-a] [-r] [-m<msg>]"
        ]

    , test "prog [options]"
        [ pass (intercalate "\n" [ "-i", "-o" ]) "prog [-i] [-o]"
        , pass (intercalate "\n" [ "-i=FOO", "-o" ]) "prog [-i=FOO] [-o]"
        , pass (intercalate "\n" [ "-i=FOO", "-o=FOO" ]) "prog [-i=FOO] [-o=FOO]"
        ]

    , test "prog [options] -o"
        [ pass (intercalate "\n" [ "-i", "-o" ]) "prog [-i] -o"
        , pass (intercalate "\n" [ "-i=FOO", "-o" ]) "prog [-i=FOO] -o"
        ]

    , test "prog -i [options] -o"
        [ pass (intercalate "\n" [ "-i", "-o" ]) "prog -i -o"
        , pass (intercalate "\n" [ "-i", "-o" ]) "prog -i -o"
        , pass (intercalate "\n" [ "-i[=FOO]", "-o" ]) "prog -i[=FOO] -o"
        ]
    ]) runTest

  where
  runTest (TestSuite smartOptions usage cases) = do
    describe ("\nusage: " <> usage <> "\n") do
      for_ cases \(TestCase description expected) ->
        let description' = if S.length description > 0
                              then description
                              else "(no description)"
         in describe description' $
          let message = case expected of
                Left err     -> "should fail with: " <> show err
                Right result -> result
           in it message $ vliftEff do
            expected' <- runEitherEff do
              case expected of
                Left err  -> pure (Left err)
                Right res -> Right <$> do
                  { program, layouts } <- do
                    toks <- Error.capture $ Lexer.lexUsage res
                    Error.capture $ SpecParser.parseUsage toks
                  pure $ Spec {
                    program
                  , helpText: ""
                  , shortHelp: ""
                  , descriptions: Nil
                  , layouts: unsafePartial $
                                ((usageToSolved <$> _) <$> _) <$> layouts
                  }
            let output' = do
                  spec <- lmap pretty do
                    { program, layouts } <- do
                      toks <- Error.capture $ Lexer.lexUsage usage
                      Error.capture $ SpecParser.parseUsage toks
                    descriptions <- do
                      toks <- Error.capture $ Lexer.lexDescs description
                      Error.capture $ SpecParser.parseDescription toks
                    pure (Spec {
                        descriptions
                      , program
                      , layouts
                      , helpText: ""
                      , shortHelp: ""
                    })
                  lmap pretty $ solve { smartOptions } spec
            case expected' /\ output' of
              Left expected /\ Left actual | expected /= actual  ->
                throwException $ error $
                  "Wrong exception! Got:\n\n" <> pretty actual
              Left _ /\ Right result ->
                throwException $ error $
                  "Missing exception! Got:\n\n" <> pretty result
              Right (Spec expected) /\ Right (Spec actual)
                | expected.layouts /= actual.layouts ->
                    throwException $ error $
                      "Unexpected output! expected:\n\n" <> pretty (Spec expected)
                      <> "\n\nbut got:\n\n" <> pretty (Spec actual)
              Right _ /\ Left err ->
                throwException $ error $ "Failure!\n" <> err
              _ -> pure unit

module Test.Spec.SolveSpec (solveSpec) where

import Prelude
import Debug.Trace
import Data.Either (Either(..), either, fromRight)
import Data.Pretty (pretty)
import Data.Tuple.Nested ((/\))
import Control.Bind ((=<<))
import Control.Apply ((*>))
import Data.List (List(..), fromFoldable)
import Data.Bifunctor (lmap, rmap)
import Control.Plus (empty)
import Data.Foldable (intercalate, for_)
import Data.Traversable (for)
import Control.Monad.Eff.Exception (error, throwException)
import Data.Array as A
import Data.Maybe (Maybe(..), maybe)
import Data.NonEmpty ((:|))
import Data.String as S

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Support (vliftEff, runEitherEff)

import Neodoc.Value
import Neodoc.Error.Class (capture) as Error
import Neodoc.Data.UsageLayout
import Neodoc.OptionAlias as OptionAlias
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.UsageLayout as Usage
import Neodoc.Spec (Spec (..))
import Neodoc.Spec.Lexer as Lexer
import Neodoc.Spec.Parser as SpecParser
import Neodoc.Spec.Parser.Usage as U
import Neodoc.Spec.Parser.Description as D
import Neodoc.Solve (solve)
import Neodoc.Solve.ExpandOptions (ExpandedOptionsLayoutArg(..), ExpandedOptionsLayout)
import Neodoc.Solve.Error (SolveError(..))
import Text.Wrap (dedent)
import Partial.Unsafe

-- | Since the solver only expands arguments, it's expanded version is valid
-- | usage input.
-- | For example: `-abc` expands to `-a -b -c`, which is valid input.
usageToSolved :: Partial => UsageLayout -> SolvedLayout
usageToSolved layout = layout <#> case _ of
  Usage.Command     n r        -> Solved.Command    n r
  Usage.Positional  n r        -> Solved.Positional n r
  Usage.Option      n a r      -> Solved.Option (OptionAlias.Long n) a r
  Usage.OptionStack (c:|_) a r -> Solved.Option (OptionAlias.Short c) a r
  Usage.EOA                    -> Solved.EOA
  Usage.Stdin                  -> Solved.Stdin

type Error = String
type Result = String
type UsageText = String
type DescriptionText = String
data TestSuite = TestSuite Boolean {- smart options? -} UsageText (Array TestCase)
data TestCase = TestCase DescriptionText (Either Error Result)

test = TestSuite false
testSmartOpts = TestSuite true

pass description expected = TestCase description (Right expected)
fail description err      = TestCase description (Left  err)

solveSpec = \_ ->
  describe "The solver" do
    for_ (fromFoldable [

      -- should not affect positionals and commands:
      test "prog foo"       [ pass "" "prog foo" ]
    , test "prog <prog>..." [ pass "" "prog <prog>..." ]

      -- options:
    , test "prog -io"
        [ pass "" "prog -i -o" ]

    , test "prog -io [-q]..."
        [ pass "" "prog -i -o [-q]..." ]

    , test "prog --foo..."
        [ fail "-f --foo=bar [default: qux]"
            "Option-Argument specified in options-section missing --foo" ]

    , test "prog --foo... BAR"
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo" ]

    , test "prog -f... BAR"
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f" ]

    , test "prog --foo BAR..."
        [ pass "-f --foo=BAR [default: qux]" "prog --foo=BAR..."
        , pass "-f --foo" "prog --foo BAR..." ]

    , test "prog --foo BAR"
        [ pass "-f --foo=BAR [default: qux]" "prog --foo=BAR"
        , pass "-f --foo" "prog --foo BAR" ]

    , test "prog --foo... BAR..."
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo" ]

    , test "prog -f... BAR..."
        [ fail "-f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f" ]

    , test "prog -xvzfFILE..."
        [ pass "-f --file=FILE [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog -xvzf=FILE..."
        [ pass "-f --file=FILE [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog -xvzf FILE..."
        [ pass "-f --file=FILE  [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog --file FILE..."
        [ fail
            """
            -f --file=FILE  [default: foo]
            -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file" ]

    , test "prog -f FILE..."
        [ fail
            """
            -f --file=FILE  [default: foo]
            -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option -f" ]

    , test "prog --file FILE..."
        [ fail
            """
            -f --file=FILE  [default: foo]
            -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file" ]

    , test "prog -fx..."
        [ fail
            "-f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments" ]

      -- Note: `f` should not adopt `file` as it's full name since it's in an
      -- option stack and not in trailing position (therefore cannot inherit the
      -- description's argument, rendering it an unfit candidate)
    , test "prog -fvzx..."
        [ fail
            "-f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments" ]

    , test "prog -xvzf FILE..."
        [ pass
            "-f --file=FILE  [default: foo]"
            "prog -x... -v... -z... -f=FILE..." ]

    , test "prog -xvzf..."
        [ fail
            "-f --file=FILE  [default: foo]"
            "Option-Argument specified in options-section missing -f" ]

      -- same adjacent arg
    , test "prog -0 ARG ARG..."
        [ pass "-0, --foo ARG [default: 100]" "prog -0=ARG ARG..." ]

      -- optional arguments
    , test "prog -f"
        [ pass "-f[=ARG]" "prog -f[=ARG]" ]

    , test "prog --file"
        [ pass "--file[=ARG]" "prog --file[=ARG]" ]

      -- smart options
    , testSmartOpts "prog [-f FILE]"
        [ pass ""   "prog [-f=FILE]"
        , pass "-f" "prog [-f FILE]"
        ]

    , testSmartOpts "prog (-f FILE)"
        [ pass ""   "prog -f=FILE"
        , pass "-f" "prog (-f FILE)"
        ]

    , testSmartOpts     "prog [-a FOO] [-b BAR] [-c QUX]"
        [ pass ""       "prog [-a=FOO] [-b=BAR] [-c=QUX]"
        , fail "-a BAR" "Arguments mismatch for option -a: \"FOO\" and \"BAR\""
        ]

    , testSmartOpts "prog (-x <foo> | -f FILE)"
        [ pass ""                  "prog (-x=<foo> | -f=FILE)"
        , pass "-x"                "prog (-x <foo> | -f=FILE)"
        , pass "-f"                "prog (-x=<foo> | -f FILE)"
        , pass "-f\n-x"            "prog (-x <foo> | -f FILE)"
        , pass "-x=<foo>"          "prog (-x=<foo> | -f=FILE)"
        , pass "-f=FILE"           "prog (-x=<foo> | -f=FILE)"
        , pass "-f=FILE\n-x=<foo>" "prog (-x=<foo> | -f=FILE)"
        ]

      -- [references]:
    , test "prog [options]"
        [ pass
            """
            -a        Add
            -r        Remote
            -m <msg>  Message
            """
            "prog ([-a] [-r] [-m<msg>])"
        ]

    , test "prog [options]"
        [ pass (intercalate "\n" [ "-i", "-o" ]) "prog ([-i] [-o])"
        , pass (intercalate "\n" [ "-i=FOO", "-o" ]) "prog ([-i=FOO] [-o])"
        , pass (intercalate "\n" [ "-i=FOO", "-o=FOO" ]) "prog ([-i=FOO] [-o=FOO])"
        ]

    , test "prog [options] -o"
        [ pass (intercalate "\n" [ "-i", "-o" ]) "prog [-i] -o"
        , pass (intercalate "\n" [ "-i=FOO", "-o" ]) "prog [-i=FOO] -o"
        ]

    , test "prog -i [options] -o"
        [ pass (intercalate "\n" [ "-i", "-o" ]) "prog -i -o"
        , pass (intercalate "\n" [ "-i", "-o" ]) "prog -i -o"
        , pass (intercalate "\n" [ "-i[=FOO]", "-o" ]) "prog -i[=FOO] -o"
        ]
    ]) runTest

  where
  runTest (TestSuite smartOptions usage cases) = do
    describe ("\nusage: " <> usage <> "\n") do
      for_ cases \(TestCase description expected) ->
        let description' = if S.length description > 0
                              then description
                              else "(no description)"
         in describe description' $
          let message = case expected of
                Left err     -> "should fail with: " <> show err
                Right result -> result
           in it message $ vliftEff do
            expected' <- runEitherEff do
              case expected of
                Left err  -> pure (Left err)
                Right res -> Right <$> do
                  { program, layouts } <- do
                    toks <- Error.capture $ Lexer.lexUsage res
                    Error.capture $ SpecParser.parseUsage toks
                  pure $ Spec {
                    program
                  , helpText: ""
                  , shortHelp: ""
                  , descriptions: Nil
                  , layouts: unsafePartial $
                                ((usageToSolved <$> _) <$> _) <$> layouts
                  }
            let output' = do
                  spec <- lmap pretty do
                    { program, layouts } <- do
                      toks <- Error.capture $ Lexer.lexUsage usage
                      Error.capture $ SpecParser.parseUsage toks
                    descriptions <- do
                      toks <- Error.capture $ Lexer.lexDescs description
                      Error.capture $ SpecParser.parseDescription toks
                    pure (Spec {
                        descriptions
                      , program
                      , layouts
                      , helpText: ""
                      , shortHelp: ""
                    })
                  lmap pretty $ solve { smartOptions } spec
            case expected' /\ output' of
              Left expected /\ Left actual | expected /= actual  ->
                throwException $ error $
                  "Wrong exception! Got:\n\n" <> pretty actual
              Left _ /\ Right result ->
                throwException $ error $
                  "Missing exception! Got:\n\n" <> pretty result
              Right (Spec expected) /\ Right (Spec actual)
                | expected.layouts /= actual.layouts ->
                    throwException $ error $
                      "Unexpected output! expected:\n\n" <> pretty (Spec expected)
                      <> "\n\nbut got:\n\n" <> pretty (Spec actual)
              Right _ /\ Left err ->
                throwException $ error $ "Failure!\n" <> err
              _ -> pure unit


Export all classes in Elm, and indent exposes nicely

Fixes #70

Original commit 51fbb125c980d923b78cabc236129115f1bb7c60

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 (forEnumerated_, removeElement, sortByKey, sortByKeyM, mapM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenNames

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

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> a -> Maybe String -> NamingResult
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbidAlso: alsoForbiddenForTypeName name }

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

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

forbiddenFromTopLevelNameGiven :: String -> Array String
forbiddenFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

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
    givenTopLevel <- upperNameStyle <$> getTopLevelNameGiven
    let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    classes <- getClasses
    unions <- getUnions
    classNames <- mapM (\t -> lookupClassName $ fst t) classes
    unionNames <- mapM lookupUnionName unions
    let exports = givenTopLevel : topLevelDecoder : topLevelEncoder : (L.concat $ classNames : unionNames : L.Nil)
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--    import Json.Decode exposing (decodeString)"""
    line $ "--    import " <> givenTopLevel <> " exposing (" <> topLevelDecoder <> ")"
    line """--
-- and you're off to the races with
--"""
    line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> givenTopLevel <> " exposing"
    indent do
        forWithPrefix_ exports "( " ", " \parenOrComma name ->
            line $ parenOrComma <> name
        line ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array exposing (Array, map)
import Dict exposing (Dict, map, toList)

-- top level type
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> givenTopLevel <> " = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> givenTopLevel
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> givenTopLevel <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    blank
    line "-- JSON types"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeDefinition i cls
    for_ unions \types -> do
        blank
        renderUnionDefinition types
    blank
    line "-- decoders and encoders"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeFunctions i cls
    for_ unions \types -> do
        blank
        renderUnionFunctions types
    blank
    line """--- encoder helpers

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

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

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< 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 { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "makeArrayEncoder" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName s

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 -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition classIndex className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions classIndex className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    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 <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    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
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"

typeRenderer :: (Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit) -> Int -> IRClassData -> Doc Unit
typeRenderer renderer classIndex (IRClassData { properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames (simpleNamer 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)
    renderer classIndex className propertyNames propsList

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    unionName <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: Set IRType -> Doc Unit
renderUnionFunctions allTypes = do
    unionName <- lookupUnionName allTypes
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \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 <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: 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 (forEnumerated_, removeElement, sortByKey, sortByKeyM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenNames

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

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> a -> Maybe String -> NamingResult
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbidAlso: alsoForbiddenForTypeName name }

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

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

forbiddenFromTopLevelNameGiven :: String -> Array String
forbiddenFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

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
    givenTopLevel <- upperNameStyle <$> getTopLevelNameGiven
    let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--    import Json.Decode exposing (decodeString)"""
    line $ "--    import " <> givenTopLevel <> " exposing (" <> topLevelDecoder <> ")"
    line """--
-- and you're off to the races with
--"""
    line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> givenTopLevel <> " exposing (" <> givenTopLevel <> ", " <> topLevelDecoder <> ", " <> topLevelEncoder <> ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array exposing (Array, map)
import Dict exposing (Dict, map, toList)

-- top level type
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> givenTopLevel <> " = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> givenTopLevel
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> givenTopLevel <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    blank
    line "-- JSON types"
    classes <- getClasses
    unions <- getUnions
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeDefinition i cls
    for_ unions \types -> do
        blank
        renderUnionDefinition types
    blank
    line "-- decoders and encoders"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeFunctions i cls
    for_ unions \types -> do
        blank
        renderUnionFunctions types
    blank
    line """--- encoder helpers

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

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

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< 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 { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "makeArrayEncoder" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName s

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 -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition classIndex className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions classIndex className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    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 <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    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
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"

typeRenderer :: (Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit) -> Int -> IRClassData -> Doc Unit
typeRenderer renderer classIndex (IRClassData { properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames (simpleNamer 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)
    renderer classIndex className propertyNames propsList

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    unionName <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: Set IRType -> Doc Unit
renderUnionFunctions allTypes = do
    unionName <- lookupUnionName allTypes
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \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 <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"


syntax error fix and new helper function

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:), singleton)
import Data.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
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.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

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

import AST as AST

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

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked :: Maybe Index, evaluated :: Maybe Index }

highlight :: Highlight -> Meta -> List String
highlight { clicked: mi, evaluated: mj } (Meta m) = case Tuple (cmp mi) (cmp mj) of
  Tuple (Just true) (Just true) -> "clicked" : "evaluated" : Nil
  Tuple (Just true) _           -> singleton "clicked"
  Tuple _           (Just true) -> singleton "evaluated"
  _                             -> Nil
 where
   cmp = map (\i -> m.index == i)

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 meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List meta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple meta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary meta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary meta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary meta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL meta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR meta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr meta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr meta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr meta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr meta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr meta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda meta binds) body) expr hole

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

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

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App meta func args
        argsDivs = zipList go (hole <<< App meta 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 "<-" ["separator"] []

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
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] 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 :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

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

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

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

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

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

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

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

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", "left"] []
    close = node "]" ["brace", "right"] []
    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", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

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

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false 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

  if needsContainer
    then pure container
    else 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 f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| 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.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
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.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

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

import AST as AST

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

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked: Maybe Index, evaluated: Maybe Index }

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 meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List meta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple meta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary meta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary meta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary meta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL meta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR meta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr meta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr meta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr meta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr meta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr meta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda meta binds) body) expr hole

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

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

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App meta func args
        argsDivs = zipList go (hole <<< App meta 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 "<-" ["separator"] []

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
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] 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 :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

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

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

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

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

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

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

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

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", "left"] []
    close = node "]" ["brace", "right"] []
    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", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

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

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false 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

  if needsContainer
    then pure container
    else 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 f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

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


Improve generated html

Improve generated html

module Web
  ( exprToDiv
  , divToJQuery
  , RoseTree
  , Callback
  ) where

import Prelude
import Data.Traversable (for)
import Data.Foldable (class Foldable)
import Data.List (List(..), snoc, toList)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

import Control.Bind ((>=>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Expr, Tree(..), Binding(..), Atom(..), Op, pPrintOp)

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

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

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

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

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

zipList :: ((Expr -> Expr) -> Expr -> Div) -> (List Expr -> Expr) -> List Expr -> List Div
zipList zipp hole Nil = Nil
zipList zipp hole (Cons x xs) = Cons (zipp (\x -> hole $ Cons x xs) x) (zipList zipp (hole <<< Cons x) xs)

exprToDiv:: Expr -> Div
exprToDiv expr = go id expr
  where
    go :: (Expr -> Expr) -> Expr -> Div
    go hole      (Atom _ a)            = atom a
    go hole expr@(List _ ls)           = list (zipList go (hole <<< List unit) ls) expr hole
    go hole expr@(NTuple _ ls)         = ntuple (zipList go (hole <<< NTuple unit) ls) expr hole
    go hole expr@(Binary _ op e1 e2)   = binary op
                                           (go (\e1 -> hole $ Binary unit op e1 e2) e1)
                                           (go (\e2 -> hole $ Binary unit op e1 e2) e2)
                                           expr hole
    go hole expr@(Unary _ op e)        = unary op (go (hole <<< Unary unit op) e) expr hole
    go hole expr@(SectL _ e op)        = sectl (go (\e -> hole $ SectL unit e op) e) op expr hole
    go hole expr@(SectR _ op e)        = sectr op (go (hole <<< SectR unit op) e) expr hole
    go hole      (PrefixOp _ op)       = prefixOp op
    go hole expr@(IfExpr _ ce te ee)   = ifexpr
                                           (go (\ce -> hole $ IfExpr unit ce te ee) ce)
                                           (go (\te -> hole $ IfExpr unit ce te ee) te)
                                           (go (\ee -> hole $ IfExpr unit ce te ee) ee)
                                           expr hole
    go hole (LetExpr _ b v e)     = letexpr (binding b) (go hole v) (go hole e) -- TODO
    go hole expr@(Lambda _ binds body) = lambda (binding <$> binds) (go (hole <<< Lambda unit binds) body) expr hole
    go hole expr@(App _ func args)     = app (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App unit func args
        argsDivs = zipList go (hole <<< App unit func) args

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

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"] []

letexpr :: Div -> Div -> Div -> Div
letexpr _ _ _ = node "" [] []

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)

binding :: Binding -> 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. Expr -> (Expr -> Expr) -> (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                -> return 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
      return unit
  return div

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

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

module Web
  ( exprToDiv
  , divToJQuery
  , RoseTree
  , Callback
  ) where

import Prelude
import Data.Traversable (for)
import Data.Foldable (class Foldable)
import Data.List (List(..), snoc, toList)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

import Control.Bind ((>=>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Expr, Tree(..), Binding(..), Atom(..), Op, pPrintOp)

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

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

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

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

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

zipList :: ((Expr -> Expr) -> Expr -> Div) -> (List Expr -> Expr) -> List Expr -> List Div
zipList zipp hole Nil = Nil
zipList zipp hole (Cons x xs) = Cons (zipp (\x -> hole $ Cons x xs) x) (zipList zipp (hole <<< Cons x) xs)

exprToDiv:: Expr -> Div
exprToDiv expr = go id expr
  where
    go :: (Expr -> Expr) -> Expr -> Div
    go hole      (Atom _ a)            = atom a
    go hole expr@(List _ ls)           = list (zipList go (hole <<< List unit) ls) expr hole
    go hole expr@(NTuple _ ls)         = ntuple (zipList go (hole <<< NTuple unit) ls) expr hole
    go hole expr@(Binary _ op e1 e2)   = binary op
                                           (go (\e1 -> hole $ Binary unit op e1 e2) e1)
                                           (go (\e2 -> hole $ Binary unit op e1 e2) e2)
                                           expr hole
    go hole expr@(Unary _ op e)        = unary op (go (hole <<< Unary unit op) e) expr hole
    go hole expr@(SectL _ e op)        = sectl (go (\e -> hole $ SectL unit e op) e) op expr hole
    go hole expr@(SectR _ op e)        = sectr op (go (hole <<< SectR unit op) e) expr hole
    go hole      (PrefixOp _ op)       = prefixOp op
    go hole expr@(IfExpr _ ce te ee)   = ifexpr
                                           (go (\ce -> hole $ IfExpr unit ce te ee) ce)
                                           (go (\te -> hole $ IfExpr unit ce te ee) te)
                                           (go (\ee -> hole $ IfExpr unit ce te ee) ee)
                                           expr hole
    go hole (LetExpr _ b v e)     = letexpr (binding b) (go hole v) (go hole e) -- TODO
    go hole expr@(Lambda _ binds body) = lambda (binding <$> binds) (go (hole <<< Lambda unit binds) body) expr hole
    go hole expr@(App _ func args)     = app (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App unit func args
        argsDivs = zipList go (hole <<< App unit func) args

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"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace"] []

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

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

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"] []

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

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"] []

letexpr :: Div -> Div -> Div -> Div
letexpr _ _ _ = node "" [] []

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"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace"] []

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

binding :: Binding -> 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. Expr -> (Expr -> Expr) -> (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                -> return 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
      return unit
  return div

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

"
  J.setText text d
  for classes (flip J.addClass d)
  return d