Update Dialog.Rename component

Update Dialog.Rename component

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Rename.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import Utils.DOM as DOM

type State = { name ∷ String }

data Query a
  = UpdateName String a
  | PreventDefault DOM.Event a
  | Save a
  | Cancel a

data Message
  = Dismiss
  | Rename String

component ∷ H.Component HH.HTML Query String Message Slam
component =
  H.component
    { initialState: { name: _ }
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ComponentHTML Query
render { name } =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-rename" ] ]
    [ HH.h4_ [ HH.text  "Rename deck" ]
    , HH.div [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
        [ HH.form
          [ HE.onSubmit (HE.input PreventDefault) ]
          [ HH.div
              [ HP.classes [ B.formGroup ]
              ]
              [ HH.input
                  [ HE.onValueInput (HE.input UpdateName)
                  , HP.value name
                  , HP.type_ HP.InputText
                  , HP.classes [ B.formControl ]
                  , ARIA.label "Deck name"
                  ]
              ]
          ]
        ]
    , HH.div [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnDefault ]
            , HE.onClick (HE.input_ Cancel)
            , HP.type_ HP.ButtonButton
            ]
            [ HH.text "Dismiss" ]
        , HH.button
            [ HP.classes [ B.btn, B.btnPrimary ]
            , HE.onClick (HE.input_ Save)
            , HP.type_ HP.ButtonButton
            ]
            [ HH.text "Save"
            ]
        ]
    ]

eval ∷ Query ~> H.ComponentDSL State Query Message Slam
eval = case _ of
  UpdateName name next →
    H.modify _ { name = name } $> next
  PreventDefault ev next →
    H.liftEff (DOM.preventDefault ev) $> next
  Save next → do
    H.raise ∘ Rename =<< H.gets _.name
    pure next
  Cancel next →
    H.raise Dismiss $> next

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Rename.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.CustomProps as CP
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)

type State = { newName ∷ String }

data Query a = SetNewName String a | Rename String a | Dismiss a

comp ∷ H.Component State Query Slam
comp = H.component { render, eval }

render ∷ State → H.ComponentHTML Query
render { newName } =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-rename" ] ]
    [ HH.h4_ [ HH.text  "Rename deck" ]
    , HH.div [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
        [ HH.form
          [ CP.nonSubmit ]
          [ HH.div
              [ HP.classes [ B.formGroup ]
              ]
              [ HH.input
                  [ HE.onValueInput $ HE.input SetNewName
                  , HP.value newName
                  , HP.type_ HP.InputText
                  , HP.classes [ B.formControl ]
                  , ARIA.label "Deck name"
                  ]
              ]
          ]
        ]
    , HH.div [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnDefault ]
            , HE.onClick (HE.input_ Dismiss)
            , HP.type_ HP.ButtonButton
            ]
            [ HH.text "Dismiss" ]
        , HH.button
            [ HP.classes [ B.btn, B.btnPrimary ]
            , HE.onClick (HE.input_ $ Rename newName)
            , HP.type_ HP.ButtonButton
            ]
            [ HH.text "Save"
            ]
        ]
    ]

eval ∷ Query ~> H.ComponentDSL State Query Slam
eval (SetNewName string next) = H.modify (_ { newName = string }) $> next
eval (Rename string next) = pure next
eval (Dismiss next) = pure next


Add basic filtering to structure viewer columns

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.StructureEditor.Common where

import SlamData.Prelude

import Data.Array as A
import Data.Eq (class Eq1, eq1)
import Data.Functor.Coproduct (Coproduct(..))
import Data.Functor.Mu (Mu)
import Data.Int as Int
import Data.Json.Extended as EJ
import Data.Json.Extended.Cursor as EJC
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Newtype as N
import Data.Ord (class Ord1, compare1)
import Data.Path.Pathy as Path

import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project, transCata)

import SlamData.Quasar.Query as QQ
import SlamData.Workspace.MillerColumns.Column.BasicFilter (mkFilter)
import SlamData.Workspace.MillerColumns.Component as MC

import Utils.Path as PU

-- Helper until we have Eq1 / Ord1 instances for Coproduct in the core lib
newtype CP1 f g a = CP1 (Coproduct f g a)

derive newtype instance functorCP1 ∷ (Functor f, Functor g) ⇒ Functor (CP1 f g)

instance eq1CP1 ∷ (Eq1 f, Eq1 g) ⇒ Eq1 (CP1 f g) where
  eq1 (CP1 (Coproduct x)) (CP1 (Coproduct y)) =
    case x, y of
      Left a, Left b → eq1 a b
      Right a, Right b → eq1 a b
      _, _ → false

instance ord1CP1 ∷ (Ord1 f, Ord1 g) ⇒ Ord1 (CP1 f g) where
  compare1 (CP1 (Coproduct x)) (CP1 (Coproduct y)) =
    case x, y of
      Left a, Left b → compare1 a b
      Left _, _ → LT
      _, Left _ → GT
      Right a, Right b → compare1 a b

toCP1 :: Mu (Coproduct EJC.CursorF ECursorF) → Mu (CP1 EJC.CursorF ECursorF)
toCP1 = transCata CP1

data ECursorF a = OfValue EJ.EJson a

derive instance functorECursorF ∷ Functor ECursorF

derive instance eqECursorF ∷ Eq a ⇒ Eq (ECursorF a)
instance eq1ECursorF ∷ Eq1 ECursorF where eq1 = eq

derive instance ordECursorF ∷ Ord a ⇒ Ord (ECursorF a)
instance ord1ECursorF ∷ Ord1 ECursorF where compare1 = compare

newtype Cursor = Cursor (Mu (Coproduct EJC.CursorF ECursorF))

derive instance newtypeCursor ∷ Newtype Cursor _

instance corecursiveCursor ∷ Corecursive Cursor (Coproduct EJC.CursorF ECursorF) where
  embed = N.collect Cursor embed

instance recursiveCursor ∷ Recursive Cursor (Coproduct EJC.CursorF ECursorF) where
  project = N.traverse Cursor project

instance eqCursor :: Eq Cursor where
  eq (Cursor x) (Cursor y) = eq (toCP1 x) (toCP1 y)

instance ordCursor :: Ord Cursor where
  compare (Cursor x) (Cursor y) = compare (toCP1 x) (toCP1 y)

all :: Cursor
all = embed $ left $ EJC.All

atKey ∷ EJ.EJson → Cursor → Cursor
atKey k = embed <<< left <<< EJC.AtKey k

atIndex ∷ Int → Cursor → Cursor
atIndex i = embed <<< left <<< EJC.AtIndex i

ofValue ∷ EJ.EJson → Cursor → Cursor
ofValue v = embed <<< right <<< OfValue v

get ∷ Cursor → EJ.EJson → Maybe EJ.EJson
get = cata go
  where
  go ∷ Algebra (Coproduct EJC.CursorF ECursorF) (EJ.EJson → Maybe EJ.EJson)
  go = unwrap >>> case _ of
    Left EJC.All → Just
    Left (EJC.AtKey k prior) → EJC.getKey k <=< prior
    Left (EJC.AtIndex i prior) → EJC.getIndex i <=< prior
    Right (OfValue val prior) → (\val' → if val == val' then Just val else Nothing) <=< prior

type ColumnPath = Cursor

rootColumn ∷ ColumnPath
rootColumn = all

printCursor ∷ Cursor → String
printCursor path = case unwrap (project path) of
  Left EJC.All → "*"
  Left (EJC.AtKey k _) → "*." <> EJ.renderEJson k <> ""
  Left (EJC.AtIndex i _) → "*[" <> show i <> "]"
  Right (OfValue val _) → EJ.renderEJson val

data ColumnItem = ColumnItem Cursor Weight

derive instance eqColumnItem ∷ Eq ColumnItem
derive instance ordColumnItem ∷ Ord ColumnItem

newtype Weight = Weight Number

derive instance eqWeight ∷ Eq Weight
derive instance ordWeight ∷ Ord Weight
derive instance newtypeWeight ∷ Newtype Weight _

columnItemLabel ∷ ColumnItem → String
columnItemLabel (ColumnItem path _) = printCursor path

columnItemPath ∷ ColumnItem → ColumnPath
columnItemPath (ColumnItem path _) = path

columnItemWeight ∷ ColumnItem → Weight
columnItemWeight (ColumnItem _ w) = w

columnPathIsLeaf ∷ ColumnPath → Boolean
columnPathIsLeaf path = case unwrap (project path) of
  Left _ → false
  Right _ → true

analyse ∷ Array EJ.EJson → ColumnPath → L.List ColumnItem
analyse items path =
  let
    items' = A.mapMaybe (get path) items
  in
    map (uncurry ColumnItem)
      $ M.toAscUnfoldable
      $ countFreq (A.length items')
      $ foldl go L.Nil items'
  where
  go :: L.List Cursor -> EJ.EJson -> L.List Cursor
  go acc item = case project item of
    EJ.Map (EJ.EJsonMap kvs) →
      foldl (\acc' (Tuple k _) → atKey k path : acc') acc kvs
    EJ.Array xs →
      foldl (\acc' x → x : acc') acc $
        A.mapWithIndex (\i _ → atIndex i path) xs
    x →
      ofValue item path : acc

countFreq ∷ ∀ f a. (Foldable f, Ord a) ⇒ Int → f a → M.Map a Weight
countFreq total = compute ∘ foldl (flip go) M.empty
  where
  go ∷ a → M.Map a Int → M.Map a Int
  go = M.alter (Just ∘ maybe 1 (_ + 1))
  compute ∷ M.Map a Int → M.Map a Weight
  compute = map (\count → Weight $ Int.toNumber count / Int.toNumber total)

load
  ∷ ∀ m
  . Monad m
  ⇒ QQ.QuasarDSL m
  ⇒ ColumnPath
  → MC.LoadRequest
  → Maybe PU.FilePath
  → m (MC.LoadResponse ColumnItem)
load path { requestId, filter } =
  case _ of
    Just resource → do
      case (fst <$> Path.peel resource) of
        Just resourcePath → do
          let sql = QQ.templated resource "SELECT * FROM {{path}} AS row LIMIT 1000"
          QQ.queryEJson resourcePath sql >>= case _ of
            Left _ →
              pure noResult
            Right records →
              let items = L.filter (mkFilter filter ∘ columnItemLabel) (analyse records path)
              in pure { requestId, items, nextOffset: Nothing }
        _ → pure noResult
    _ → pure noResult
  where
  noResult = { requestId, items: L.Nil, nextOffset: Nothing }

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.StructureEditor.Common where

import SlamData.Prelude

import Data.Array as A
import Data.Eq (class Eq1, eq1)
import Data.Functor.Coproduct (Coproduct(..))
import Data.Functor.Mu (Mu)
import Data.Int as Int
import Data.Json.Extended as EJ
import Data.Json.Extended.Cursor as EJC
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Newtype as N
import Data.Ord (class Ord1, compare1)
import Data.Path.Pathy as Path

import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project, transCata)

import SlamData.Quasar.Query as QQ
import SlamData.Workspace.MillerColumns.Component as MC

import Utils.Path as PU

-- Helper until we have Eq1 / Ord1 instances for Coproduct in the core lib
newtype CP1 f g a = CP1 (Coproduct f g a)

derive newtype instance functorCP1 ∷ (Functor f, Functor g) ⇒ Functor (CP1 f g)

instance eq1CP1 ∷ (Eq1 f, Eq1 g) ⇒ Eq1 (CP1 f g) where
  eq1 (CP1 (Coproduct x)) (CP1 (Coproduct y)) =
    case x, y of
      Left a, Left b → eq1 a b
      Right a, Right b → eq1 a b
      _, _ → false

instance ord1CP1 ∷ (Ord1 f, Ord1 g) ⇒ Ord1 (CP1 f g) where
  compare1 (CP1 (Coproduct x)) (CP1 (Coproduct y)) =
    case x, y of
      Left a, Left b → compare1 a b
      Left _, _ → LT
      _, Left _ → GT
      Right a, Right b → compare1 a b

toCP1 :: Mu (Coproduct EJC.CursorF ECursorF) → Mu (CP1 EJC.CursorF ECursorF)
toCP1 = transCata CP1

data ECursorF a = OfValue EJ.EJson a

derive instance functorECursorF ∷ Functor ECursorF

derive instance eqECursorF ∷ Eq a ⇒ Eq (ECursorF a)
instance eq1ECursorF ∷ Eq1 ECursorF where eq1 = eq

derive instance ordECursorF ∷ Ord a ⇒ Ord (ECursorF a)
instance ord1ECursorF ∷ Ord1 ECursorF where compare1 = compare

newtype Cursor = Cursor (Mu (Coproduct EJC.CursorF ECursorF))

derive instance newtypeCursor ∷ Newtype Cursor _

instance corecursiveCursor ∷ Corecursive Cursor (Coproduct EJC.CursorF ECursorF) where
  embed = N.collect Cursor embed

instance recursiveCursor ∷ Recursive Cursor (Coproduct EJC.CursorF ECursorF) where
  project = N.traverse Cursor project

instance eqCursor :: Eq Cursor where
  eq (Cursor x) (Cursor y) = eq (toCP1 x) (toCP1 y)

instance ordCursor :: Ord Cursor where
  compare (Cursor x) (Cursor y) = compare (toCP1 x) (toCP1 y)

all :: Cursor
all = embed $ left $ EJC.All

atKey ∷ EJ.EJson → Cursor → Cursor
atKey k = embed <<< left <<< EJC.AtKey k

atIndex ∷ Int → Cursor → Cursor
atIndex i = embed <<< left <<< EJC.AtIndex i

ofValue ∷ EJ.EJson → Cursor → Cursor
ofValue v = embed <<< right <<< OfValue v

get ∷ Cursor → EJ.EJson → Maybe EJ.EJson
get = cata go
  where
  go ∷ Algebra (Coproduct EJC.CursorF ECursorF) (EJ.EJson → Maybe EJ.EJson)
  go = unwrap >>> case _ of
    Left EJC.All → Just
    Left (EJC.AtKey k prior) → EJC.getKey k <=< prior
    Left (EJC.AtIndex i prior) → EJC.getIndex i <=< prior
    Right (OfValue val prior) → (\val' → if val == val' then Just val else Nothing) <=< prior

type ColumnPath = Cursor

rootColumn ∷ ColumnPath
rootColumn = all

printCursor ∷ Cursor → String
printCursor path = case unwrap (project path) of
  Left EJC.All → "*"
  Left (EJC.AtKey k _) → "*." <> EJ.renderEJson k <> ""
  Left (EJC.AtIndex i _) → "*[" <> show i <> "]"
  Right (OfValue val _) → EJ.renderEJson val

data ColumnItem = ColumnItem Cursor Weight

derive instance eqColumnItem ∷ Eq ColumnItem
derive instance ordColumnItem ∷ Ord ColumnItem

newtype Weight = Weight Number

derive instance eqWeight ∷ Eq Weight
derive instance ordWeight ∷ Ord Weight
derive instance newtypeWeight ∷ Newtype Weight _

columnItemLabel ∷ ColumnItem → String
columnItemLabel (ColumnItem path _) = printCursor path

columnItemPath ∷ ColumnItem → ColumnPath
columnItemPath (ColumnItem path _) = path

columnItemWeight ∷ ColumnItem → Weight
columnItemWeight (ColumnItem _ w) = w

columnPathIsLeaf ∷ ColumnPath → Boolean
columnPathIsLeaf path = case unwrap (project path) of
  Left _ → false
  Right _ → true

analyse ∷ Array EJ.EJson → ColumnPath → L.List ColumnItem
analyse items path =
  let
    items' = A.mapMaybe (get path) items
  in
    map (uncurry ColumnItem)
      $ M.toAscUnfoldable
      $ countFreq (A.length items')
      $ foldl go L.Nil items'
  where
  go :: L.List Cursor -> EJ.EJson -> L.List Cursor
  go acc item = case project item of
    EJ.Map (EJ.EJsonMap kvs) →
      foldl (\acc' (Tuple k _) → atKey k path : acc') acc kvs
    EJ.Array xs →
      foldl (\acc' x → x : acc') acc $
        A.mapWithIndex (\i _ → atIndex i path) xs
    x →
      ofValue item path : acc

countFreq ∷ ∀ f a. (Foldable f, Ord a) ⇒ Int → f a → M.Map a Weight
countFreq total = compute ∘ foldl (flip go) M.empty
  where
  go ∷ a → M.Map a Int → M.Map a Int
  go = M.alter (Just ∘ maybe 1 (_ + 1))
  compute ∷ M.Map a Int → M.Map a Weight
  compute = map (\count → Weight $ Int.toNumber count / Int.toNumber total)

load
  ∷ ∀ m
  . Monad m
  ⇒ QQ.QuasarDSL m
  ⇒ ColumnPath
  → MC.LoadRequest
  → Maybe PU.FilePath
  → m (MC.LoadResponse ColumnItem)
load path { requestId, filter } =
  case _ of
    Just resource → do
      case (fst <$> Path.peel resource) of
        Just resourcePath → do
          let sql = QQ.templated resource "SELECT * FROM {{path}} AS row LIMIT 1000"
          QQ.queryEJson resourcePath sql >>= case _ of
            Left _ →
              pure noResult
            Right records →
              pure { requestId, items: analyse records path, nextOffset: Nothing }
        _ → pure noResult
    _ → pure noResult
  where
  noResult = { requestId, items: L.Nil, nextOffset: Nothing }


more tests

more tests

module Main where

import Test.QuickCheck
import qualified Data.Array as A
import Data.Array.NonEmpty
import Debug.Trace
import Data.Maybe.Unsafe

foreign import undefined :: forall a. a

instance arbNonEmpty :: (Arbitrary a) => Arbitrary (NonEmpty a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

qc :: String -> (NonEmpty Number -> Boolean) -> QC Unit
qc name f = do
    quickCheck (\x -> (f x) <?> name ++ " failed")
    return unit

qc_ll :: String -> (NonEmpty Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_ll name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

qc_nl :: String -> (Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_nl name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

main = do
    qc "Self equality" \x -> x == x
    qc "Inequality" \x -> x /= push 0 x
    qc "Length" \x -> length x == A.length (toArray x)
    qc "Pop - Length" \x -> A.length (pop x) == A.length (toArray x) - 1
    qc "Pop - Head" \(NonEmpty a as) -> let popped = pop (NonEmpty a as) in A.length popped == 0 || (fromJust $ A.head popped) == a
    qc "Take" \xs -> take (length xs) xs == toArray xs
    qc "Drop" \xs -> A.length (drop (length xs) xs) == 0
    qc "Drop 1" \xs -> drop 1 xs == tail xs
    qc "Reverse" \xs -> reverse (reverse xs) == xs
    qc_ll "Append - Length" \xs ys -> length (xs `append` ys) == length xs + length ys
    qc_nl "Cons - Length" \x xs -> length (x <| xs) == length xs + 1
    qc_nl "Cons - Head" \x xs -> head (x <| xs) == x
    qc_nl "Cons - Tail" \x xs -> tail (x <| xs) == toArray xs
    qc "Last" \(NonEmpty a as) -> let x = (NonEmpty a as) in (A.length as == 0 && last x == a) || (last x == fromJust (A.last as))
    qc "nub" \xs -> xs == nub (xs `append` xs)
    qc "nubBy" \xs -> xs == nubBy (==) (xs `append` xs)
    qc "functor - identity" \xs -> (\x -> x) <$> xs == xs
    qc "functor - composition" \xs -> ((+) 1) <$> ((+) 2) <$> xs == ((+) 3) <$> xs

module Main where

import Test.QuickCheck
import qualified Data.Array as A
import Data.Array.NonEmpty
import Debug.Trace
import Data.Maybe.Unsafe

foreign import undefined :: forall a. a

instance arbNonEmpty :: (Arbitrary a) => Arbitrary (NonEmpty a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

qc :: String -> (NonEmpty Number -> Boolean) -> QC Unit
qc name f = do
    quickCheck (\x -> (f x) <?> name ++ " failed")
    return unit

qc_ll :: String -> (NonEmpty Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_ll name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

qc_nl :: String -> (Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_nl name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

main = do
    qc "Self equality" \x -> x == x
    qc "Inequality" \x -> x /= push 0 x
    qc "Length" \x -> length x == A.length (toArray x)
    qc "Pop - Length" \x -> A.length (pop x) == A.length (toArray x) - 1
    qc "Pop - Head" \(NonEmpty a as) -> let popped = pop (NonEmpty a as) in A.length popped == 0 || (fromJust $ A.head popped) == a
    qc "Take" \xs -> take (length xs) xs == toArray xs
    qc "Drop" \xs -> A.length (drop (length xs) xs) == 0
    qc "Drop 1" \xs -> drop 1 xs == tail xs
    qc "Reverse" \xs -> reverse (reverse xs) == xs
    qc_ll "Append - Length" \xs ys -> length (append xs ys) == length xs + length ys
    qc_nl "Cons - Length" \x xs -> length (x <| xs) == length xs + 1
    qc_nl "Cons - Head" \x xs -> head (x <| xs) == x
    qc_nl "Cons - Tail" \x xs -> tail (x <| xs) == toArray xs
    qc "Last" \(NonEmpty a as) -> let x = (NonEmpty a as) in (A.length as == 0 && last x == a) || (last x == fromJust (A.last as))


Add functor instance for binding

Add functor instance for binding

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b o m =
    Atom      m a
  | List      m (List (Tree a b o m))
  | NTuple    m (List (Tree a b o m))
  | Binary    m o (Tree a b o m) (Tree a b o m)
  | Unary     m o (Tree a b o m)
  | SectL     m (Tree a b o m) o
  | SectR     m o (Tree a b o m)
  | PrefixOp  m o
  | IfExpr    m (Tree a b o m) (Tree a b o m) (Tree a b o m)
  | ArithmSeq m (Tree a b o m) (Maybe (Tree a b o m)) (Maybe (Tree a b o m))
  | LetExpr   m (List (Tuple b (Tree a b o m))) (Tree a b o m)
  | Lambda    m (List b) (Tree a b o m)
  | App       m (Tree a b o m) (List (Tree a b o m))
  | ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))

-- type Expr = Tree Atom (Binding Unit) Op Unit

-- type MType = Maybe Type

-- type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

exprToTypeTree :: Expr -> TypeTree
exprToTypeTree expr = case expr of
  (Atom m a) -> Atom Nothing a
  _ -> PrefixOp Nothing (Tuple Add Nothing)

binary :: Op -> TypeTree -> TypeTree -> TypeTree
binary op left right = Binary Nothing (Tuple op Nothing) left right

data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorQualTree :: Functor (QualTree b e) where
  map f (Gen d b e) = Gen (f d) b e
  map f (Let d b e) = Let (f d) b e
  map f (Guard d e) = Guard (f d) e

instance functorTree :: Functor (Tree a b c) where
  map f (Atom c a) = Atom (f c) a
  map f (List c xs) = List (f c) (map f <$> xs)
  map f (NTuple c xs) = List (f c) (map f <$> xs)
  map f (Binary c op t1 t2) = Binary (f c) op (map f t1) (map f t2)
  map f (Unary c op t) = Unary (f c) op (map f t)
  map f (SectL c t op) = SectL (f c) (map f t) op
  map f (SectR c op t) = SectR (f c) op (map f t)
  map f (PrefixOp c op) = PrefixOp (f c) op
  map f (IfExpr c t1 t2 t3) = IfExpr (f c) (map f t1) (map f t2) (map f t3)
  map f (ArithmSeq c t1 t2 t3) = ArithmSeq (f c) (map f t1) (map f <$> t2) (map f <$> t3)
  map f (LetExpr c bs t) = LetExpr (f c) (map (rmap (map f)) bs) (map f t)
  map f (Lambda c bs t) = Lambda (f c) bs (map f t)
  map f (App c t ts) = App (f c) (map f t) (map f <$> ts)
  map f (ListComp c t ts) = ListComp (f c) (map f t) (map go ts)
    where
    go (Gen d b e) = Gen (f d) b (map f e)
    go (Let d b e) = Let (f d) b (map f e)
    go (Guard d e) = Guard (f d) (map f e)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

-- type Expr = Tree Atom (Binding Unit) Op Unit
-- type TypeTree = Tree Atom (Binding Type) (Tuple Op Type) Type
type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

type ExprQualTree = QualTree (Binding Unit) Expr Unit

type TypeQual  = QualTree (Binding MType) TypeTree MType

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding m = Lit       m Atom
               | ConsLit   m (Binding m) (Binding m)
               | ListLit   m (List (Binding m))
               | NTupleLit m (List (Binding m))

derive instance eqBinding :: (Eq a) => Eq (Binding a)

instance functorBinding :: Functor Binding where
  map f (Lit x atom) = Lit (f x) atom
  map f (ConsLit x binding1 binding2) = ConsLit (f x) (f <$> binding1) (f <$> binding2)
  map f (ListLit x bindings) = ListLit (f x) (map f <$> bindings)
  map f (NTupleLit x bindings) = NTupleLit (f x) (map f <$> bindings)

type TypedBinding = Binding (Maybe Type)

extractFromBinding :: forall a. Binding a -> a
extractFromBinding (Lit x _)       = x
extractFromBinding (ConsLit x _ _) = x
extractFromBinding (ListLit x _)   = x
extractFromBinding (NTupleLit x _) = x

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List (Binding MType)) TypeTree

derive instance eqDefintion :: Eq Definition

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: (Show a) => Show (Binding a) where
  show binding = case binding of
    Lit m atom     -> "(Lit " <> show m <> " " <> show atom <> ")"
    ConsLit m b bs -> "(ConsLit " <> show m <> " " <> show b <> " " <> show bs <> ")"
    ListLit m bs   -> "(ListLit " <> show m <> " " <> show bs <> ")"
    NTupleLit m ls -> "(NTupleLit " <> show m <> " " <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b o m =
    Atom      m a
  | List      m (List (Tree a b o m))
  | NTuple    m (List (Tree a b o m))
  | Binary    m o (Tree a b o m) (Tree a b o m)
  | Unary     m o (Tree a b o m)
  | SectL     m (Tree a b o m) o
  | SectR     m o (Tree a b o m)
  | PrefixOp  m o
  | IfExpr    m (Tree a b o m) (Tree a b o m) (Tree a b o m)
  | ArithmSeq m (Tree a b o m) (Maybe (Tree a b o m)) (Maybe (Tree a b o m))
  | LetExpr   m (List (Tuple b (Tree a b o m))) (Tree a b o m)
  | Lambda    m (List b) (Tree a b o m)
  | App       m (Tree a b o m) (List (Tree a b o m))
  | ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))

-- type Expr = Tree Atom (Binding Unit) Op Unit

-- type MType = Maybe Type

-- type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

exprToTypeTree :: Expr -> TypeTree
exprToTypeTree expr = case expr of
  (Atom m a) -> Atom Nothing a
  _ -> PrefixOp Nothing (Tuple Add Nothing)

binary :: Op -> TypeTree -> TypeTree -> TypeTree
binary op left right = Binary Nothing (Tuple op Nothing) left right

data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorQualTree :: Functor (QualTree b e) where
  map f (Gen d b e) = Gen (f d) b e
  map f (Let d b e) = Let (f d) b e
  map f (Guard d e) = Guard (f d) e

instance functorTree :: Functor (Tree a b c) where
  map f (Atom c a) = Atom (f c) a
  map f (List c xs) = List (f c) (map f <$> xs)
  map f (NTuple c xs) = List (f c) (map f <$> xs)
  map f (Binary c op t1 t2) = Binary (f c) op (map f t1) (map f t2)
  map f (Unary c op t) = Unary (f c) op (map f t)
  map f (SectL c t op) = SectL (f c) (map f t) op
  map f (SectR c op t) = SectR (f c) op (map f t)
  map f (PrefixOp c op) = PrefixOp (f c) op
  map f (IfExpr c t1 t2 t3) = IfExpr (f c) (map f t1) (map f t2) (map f t3)
  map f (ArithmSeq c t1 t2 t3) = ArithmSeq (f c) (map f t1) (map f <$> t2) (map f <$> t3)
  map f (LetExpr c bs t) = LetExpr (f c) (map (rmap (map f)) bs) (map f t)
  map f (Lambda c bs t) = Lambda (f c) bs (map f t)
  map f (App c t ts) = App (f c) (map f t) (map f <$> ts)
  map f (ListComp c t ts) = ListComp (f c) (map f t) (map go ts)
    where
    go (Gen d b e) = Gen (f d) b (map f e)
    go (Let d b e) = Let (f d) b (map f e)
    go (Guard d e) = Guard (f d) (map f e)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

-- type Expr = Tree Atom (Binding Unit) Op Unit
-- type TypeTree = Tree Atom (Binding Type) (Tuple Op Type) Type
type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

type ExprQualTree = QualTree (Binding Unit) Expr Unit

type TypeQual  = QualTree (Binding MType) TypeTree MType

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding m = Lit       m Atom
               | ConsLit   m (Binding m) (Binding m)
               | ListLit   m (List (Binding m))
               | NTupleLit m (List (Binding m))

derive instance eqBinding :: (Eq a) => Eq (Binding a)

type TypedBinding = Binding (Maybe Type)

extractFromBinding :: forall a. Binding a -> a
extractFromBinding (Lit x _)       = x
extractFromBinding (ConsLit x _ _) = x
extractFromBinding (ListLit x _)   = x
extractFromBinding (NTupleLit x _) = x

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List (Binding MType)) TypeTree

derive instance eqDefintion :: Eq Definition

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: (Show a) => Show (Binding a) where
  show binding = case binding of
    Lit m atom     -> "(Lit " <> show m <> " " <> show atom <> ")"
    ConsLit m b bs -> "(ConsLit " <> show m <> " " <> show b <> " " <> show bs <> ")"
    ListLit m bs   -> "(ListLit " <> show m <> " " <> show bs <> ")"
    NTupleLit m ls -> "(NTupleLit " <> show m <> " " <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str


Code formatting fix

Code formatting fix

module Node.FS
  ( FS()
  , FileDescriptor(..)
  , FileFlags(..)
  , FileMode(..)
  , SymlinkType(..)
  , BufferLength(..)
  , BufferOffset(..)
  , ByteCount(..)
  , FilePosition(..)
  , fileFlagsToNode
  ) where

import Prelude

-- |
-- Effect type for file system usage.
--
foreign import data FS :: !

foreign import data FileDescriptor :: *

data FileFlags = R | R_PLUS | RS | RS_PLUS
               | W | WX | W_PLUS | WX_PLUS
               | A | AX | A_PLUS | AX_PLUS

fileFlagsToNode :: FileFlags -> String
fileFlagsToNode ff = case ff of
  R       -> "r"
  R_PLUS  -> "r+"
  RS      -> "rs"
  RS_PLUS -> "rs+"
  W       -> "w"
  WX      -> "wx"
  W_PLUS  -> "w+"
  WX_PLUS -> "wx+"
  A       -> "a"
  AX      -> "ax"
  A_PLUS  -> "a+"
  AX_PLUS -> "ax+"

type FileMode = Int
type FilePosition = Int
type BufferLength = Int
type BufferOffset = Int
type ByteCount = Int

-- |
-- Symlink varieties.
--
data SymlinkType = FileLink | DirLink | JunctionLink

instance showSymlinkType :: Show SymlinkType where
  show FileLink     = "file"
  show DirLink      = "dir"
  show JunctionLink = "junction"

instance eqSymlinkType :: Eq SymlinkType where
  eq FileLink     FileLink     = true
  eq DirLink      DirLink      = true
  eq JunctionLink JunctionLink = true
  eq _ _ = false


holes should not cast away the meta information

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

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 AST.emptyMeta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple AST.emptyMeta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary AST.emptyMeta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL AST.emptyMeta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR AST.emptyMeta 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 AST.emptyMeta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr AST.emptyMeta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr AST.emptyMeta 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 AST.emptyMeta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr AST.emptyMeta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda AST.emptyMeta binds) body) expr hole

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

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

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App AST.emptyMeta func args
        argsDivs = zipList go (hole <<< App AST.emptyMeta 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