Workaround syntax highlight fail

Workaround syntax highlight fail

module IdePurescript.Atom.Main where

import Prelude
import Control.Promise as Promise
import IdePurescript.Atom.Completion as C
import IdePurescript.Atom.Psci as Psci
import PscIde as P
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (EDITOR, TextEditor, toEditor, onDidSave, getText, getPath, getTextInRange, setTextInBufferRange, setText, getBuffer, getCursorBufferPosition)
import Atom.NotificationManager (NOTIFY, addError)
import Atom.Point (Point, getRow, getColumn, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange, Range, getStart, getEnd)
import Atom.TextBuffer (setTextViaDiff)
import Atom.Workspace (WORKSPACE, onDidChangeActivePaneItem, observeTextEditors, getActiveTextEditor)
import Control.Bind (join)
import Control.Monad (when)
import Control.Monad.Aff (runAff, Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log, error)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF, Ref, readRef, writeRef, newRef)
import Control.Monad.Error.Class (catchError)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT, lift)
import Control.Promise (Promise)
import DOM (DOM)
import DOM.Node.Types (Element)
import Data.Array (length)
import Data.Either (either, Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (readBoolean)
import Data.Function.Eff (mkEffFn1)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import IdePurescript.Atom.Build (AtomLintMessage)
import IdePurescript.Atom.BuildStatus (getBuildStatus)
import IdePurescript.Atom.Config (config)
import IdePurescript.Atom.Hooks.Dependencies (installDependencies)
import IdePurescript.Atom.Hooks.Linter (LinterInternal, LinterIndie, LINTER, register)
import IdePurescript.Atom.Hooks.StatusBar (addLeftTile)
import IdePurescript.Atom.LinterBuild (lint, getProjectRoot)
import IdePurescript.Atom.PromptPanel (addPromptPanel)
import IdePurescript.Atom.PscIdeServer (startServer)
import IdePurescript.Atom.QuickFixes (showQuickFixes)
import IdePurescript.Atom.SelectView (selectListViewStatic, selectListViewDynamic)
import IdePurescript.Atom.Tooltips (registerTooltips, getToken)
import IdePurescript.Modules (State, ImportResult(AmbiguousImport, UpdatedImports), getQualModule, addModuleImport, addExplicitImport, initialModulesState, getModulesForFile, getMainModule)
import IdePurescript.PscIde (getPursuitModuleCompletion, getPursuitCompletion, loadDeps, getAvailableModules, getCompletion, eitherToErr, getLoadedModules)
import Node.ChildProcess (CHILD_PROCESS)
import Node.FS (FS)
import PscIde (NET)
import PscIde.Command (Completion(..))

getSuggestions :: forall eff. State -> { editor :: TextEditor, bufferPosition :: Point }
  -> Eff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Promise (Array C.AtomSuggestion))
getSuggestions state ({editor, bufferPosition}) = Promise.fromAff $ flip catchError (raiseError' []) $ do
  let range = mkRange (mkPoint (getRow bufferPosition) 0) bufferPosition
  line <- liftEff $ getTextInRange editor range
  modules <- getLoadedModules -- getUnqualActiveModules state
  let getQualifiedModule = (flip getQualModule) state
  C.getSuggestions { line, moduleInfo: { modules, getQualifiedModule }}
  where
  raiseError' :: (Array C.AtomSuggestion) -> Error -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Array C.AtomSuggestion)
  raiseError' x e = do
    liftEff $ raiseError e
    pure x

useEditor :: forall eff. (Ref State) -> TextEditor -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE | eff) Unit
useEditor modulesStateRef editor = do
  path <- getPath editor
  text <- getText editor
  let mainModule = getMainModule text
  case mainModule of
    Just m -> runAff logError ignoreError $ do
      loadDeps m
      state <- getModulesForFile path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type MainEff =
  ( command :: COMMAND
  , note :: NOTIFY
  , project :: PROJECT
  , fs :: FS
  , ref :: REF
  , cp :: CHILD_PROCESS
  , console :: CONSOLE
  , config :: CONFIG
  , linter :: LINTER
  , editor :: EDITOR
  , net :: NET
  , workspace :: WORKSPACE
  , avar :: AVAR
  , err :: EXCEPTION
  , dom :: DOM
  )

main :: _
main = do
  atom <- getAtom
  linterIndieRef <- newRef (Nothing :: Maybe LinterIndie)
  modulesState <- newRef (initialModulesState)
  messagesRef <- newRef ([] :: Array AtomLintMessage)
  linterInternalRef <- newRef (Nothing :: Maybe LinterInternal)
  deactivateRef <- newRef (pure unit :: Eff MainEff Unit)
  buildStatusRef <- newRef (Nothing :: Maybe Element)

  let
    doLint :: Eff MainEff Unit
    doLint = do
      root <- getProjectRoot
      linterIndie <- readRef linterIndieRef
      statusElt <- readRef buildStatusRef
      case { root, linterIndie, statusElt } of
        { root: Just root', linterIndie: Just linterIndie', statusElt: Just statusElt' } -> runAff raiseError ignoreError $ do
          messages <- lint atom.config root' linterIndie' statusElt'
          liftEff $ maybe (pure unit) (writeRef messagesRef) messages
          editor <- liftEff $ getActiveTextEditor atom.workspace
          liftEff $ maybe (pure unit) (useEditor modulesState) editor
          pure unit
        _ -> pure unit

    quickFix :: Eff MainEff Unit
    quickFix = do
      messages <- readRef messagesRef
      editor <- getActiveTextEditor atom.workspace
      linter <- readRef linterInternalRef
      case { editor, linter, n: length messages } of
        { editor: Just e, linter: Just l, n } | n > 0 -> showQuickFixes e l messages
        _ -> pure unit

    pursuitSearch :: Eff MainEff Unit
    pursuitSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") getPursuitCompletion 1000
      where
      view {identifier, "type": ty, "module": mod, package} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ " (" ++ package ++ ")
"
         ++ "
"

    pursuitSearchModule :: Eff MainEff Unit
    pursuitSearchModule = selectListViewDynamic view importDialog (Just "module") id getPursuitModuleCompletion 1000
      where
      view {"module": mod, package} =
         "
"
         ++ "
" ++ mod ++ "
"
         ++ "
" ++ package ++ "
"
         ++ "
"
      importDialog :: forall a. {"module" :: String | a} -> Eff MainEff Unit
      importDialog {"module": mod} = selectListViewStatic textView (doImport mod) Nothing ["Import module", "Cancel"]
        where
        textView x = "
" ++ x ++ "
"
        doImport mod x = when (x == "Import module") $ addImport mod

    addModuleImportCmd :: Eff MainEff Unit
    addModuleImportCmd = runAff raiseError ignoreError do
      modules <- getAvailableModules
      liftEff $ selectListViewStatic view addImport Nothing modules
      where
        view x = "
" ++ x ++ "
"

    addExplicitImportCmd :: Eff MainEff Unit
    addExplicitImportCmd = runAff raiseError ignoreError do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      case editor of
        Just ed -> do
          { line, col, pos, range } <- liftEff $ getLinePosition ed
          promptText <- liftEff $ maybe "" _.word <$> getToken ed pos
          res <- addPromptPanel "Identifier" promptText
          maybe (pure unit) (addIdentImport Nothing) res
        Nothing -> pure unit

    addIdentImport :: Maybe String -> String -> Aff MainEff Unit
    addIdentImport moduleName ident = do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      maybe (pure unit) (addIdentImport' moduleName ident) editor

    addIdentImport' :: Maybe String -> String -> TextEditor -> Aff MainEff Unit
    addIdentImport' moduleName ident editor = do
      text <- liftEff $ getText editor
      path <- liftEff $ getPath editor
      state <- liftEff $ readRef modulesState
      { state: newState, result: output} <- addExplicitImport state path text moduleName ident
      liftEff $ writeRef modulesState newState
      liftEff $ case output of
        UpdatedImports out -> do
          buf <- getBuffer editor
          void $ setTextViaDiff buf out
        AmbiguousImport opts -> do
          selectListViewStatic view addImp Nothing (runCompletion <$> opts)
        _ -> pure unit
      where
      runCompletion (Completion obj) = obj
      -- TODO nicer if we can make select view aff-ish
      addImp { identifier, "module'": m } = runAff raiseError ignoreError $ addIdentImport (Just m) identifier
      view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"

    addSuggestionImport :: { editor :: TextEditor, suggestion :: C.AtomSuggestion } -> Aff MainEff Unit
    addSuggestionImport { editor, suggestion: { addImport: Just { mod, identifier, qualifier: Nothing } } } =
      addIdentImport' (Just mod) identifier editor
    addSuggestionImport _ = pure unit

    addImport :: String -> Eff MainEff Unit
    addImport moduleName = do
      maybeEditor <- getActiveTextEditor atom.workspace
      state <- liftEff $ readRef modulesState
      case maybeEditor of
        Nothing -> pure unit
        Just editor -> do
          text <- getText editor
          path <- getPath editor
          runAff raiseError ignoreError $ do
            output <- addModuleImport state path text moduleName
            liftEff $ maybe (pure unit) (void <<< setText editor <<< _.result) output

    localSearch :: Eff MainEff Unit
    localSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") search 50
      where
      search text = do
        state <- liftEff $ readRef modulesState
        modules <- getLoadedModules
        let getQualifiedModule = (flip getQualModule) state
        getCompletion text "" false modules getQualifiedModule

      view {identifier, "type": ty, "module": mod} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ "
"
         ++ "
"

    getLinePosition :: TextEditor -> Eff MainEff { line :: String, col :: Int, pos :: Point, range :: Range }
    getLinePosition ed = do
      pos <- getCursorBufferPosition ed
      let range = mkRange (mkPoint (getRow pos) 0) (mkPoint (getRow pos) 1000)
          col = getColumn pos
      line <- getTextInRange ed range
      pure { line, pos, col, range }

    caseSplit :: Eff MainEff Unit
    caseSplit = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        ty <- MaybeT $ addPromptPanel "Parameter type" ""
        lines <- lift $ eitherToErr $ P.caseSplit line (getColumn $ getStart wordRange) (getColumn $ getEnd wordRange) true ty
        lift $ void $ liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines

    addClause :: Eff MainEff Unit
    addClause = do
      editor <- getActiveTextEditor atom.workspace
      case editor of
        Just ed ->
          runAff raiseError ignoreError $ do
            { line, col, range } <- liftEff $ getLinePosition ed
            lines <- eitherToErr $ P.addClause line true
            liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines
        Nothing -> pure unit

    fixTypo :: Eff MainEff Unit
    fixTypo = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { word, range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        corrections <- lift $ eitherToErr (P.suggestTypos word 2)
        liftEff $ selectListViewStatic view (replaceTypo ed wordRange) Nothing (runCompletion <$> corrections)
        where
          runCompletion (Completion obj) = obj
          replaceTypo ed wordRange { identifier, "module'": mod } =
            runAff raiseError ignoreError do
             liftEff $ setTextInBufferRange ed wordRange identifier
             addIdentImport (Just mod) identifier
          view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"
          getIdentFromCompletion (Completion c) = c.identifier

    activate :: Eff MainEff Unit
    activate = do
      let cmd name action = addCommand atom.commands "atom-workspace" ("purescript:"++name) (const action)
      cmd "build" doLint
      cmd "show-quick-fixes" quickFix
      cmd "pursuit-search" pursuitSearch
      cmd "pursuit-search-modules" pursuitSearchModule
      cmd "add-module-import" addModuleImportCmd
      cmd "add-explicit-import" addExplicitImportCmd
      cmd "search" localSearch
      cmd "case-split" caseSplit
      cmd "add-clause" addClause
      cmd "fix-typo" fixTypo

      installDependencies

      observeTextEditors atom.workspace (\editor -> do -- TODO: Check if file is .purs
        useEditor modulesState editor
        onDidSave editor (\_ -> do
          buildOnSave <- getConfig atom.config "ide-purescript.buildOnSave"
          when (either (const false) id $ readBoolean buildOnSave) doLint -- TODO: Check if file is in project
        )
      )

      onDidChangeActivePaneItem atom.workspace (\item ->
        maybe (pure unit) (useEditor modulesState) (toEditor item)
      )

      registerTooltips modulesState
      runAff
        (\_ -> log "Error starting server")
        (\deact -> do
            writeRef deactivateRef deact
            editor <- getActiveTextEditor atom.workspace
            maybe (pure unit) (useEditor modulesState) editor)
        startServer
      Psci.init

    deactivate :: Eff MainEff Unit
    deactivate = join (readRef deactivateRef)

  pure
    { config
    , activate: mkEffFn1 \_ -> activate
    , deactivate: mkEffFn1 \_ -> deactivate
    , consumeLinterIndie: mkEffFn1 \registry -> do
        linterIndie <- register registry {name: "PureScript"}
        writeRef linterIndieRef $ Just linterIndie
    , consumeLinterInternal: mkEffFn1 \linter ->
        writeRef linterInternalRef $ Just linter
    , consumeStatusBar: mkEffFn1 \statusBar -> do
        item <- getBuildStatus
        writeRef buildStatusRef $ Just item
        addLeftTile statusBar { item, priority: -50 }
    , provideAutocomplete: \_ ->
        { selector: ".source.purescript"
        , disableForSelector: ".source.purescript .comment, .source.purescript .string"
        , inclusionPriority: 1
        , excludeLowerPriority: true
        , getSuggestions: mkEffFn1 $ \x -> do
            state <- readRef modulesState
            getSuggestions state x
        , onDidInsertSuggestion: mkEffFn1 \x -> do
            shouldAddImport <- getConfig atom.config "ide-purescript.importOnAutocomplete"
            when (readBoolean shouldAddImport == Right true)
              (runAff raiseError ignoreError $ addSuggestionImport x)
        }
    }

raiseError :: forall eff. Error -> Eff (note :: NOTIFY | eff) Unit
raiseError e = do
  atom <- getAtom
  addError atom.notifications (show e)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

logError :: forall eff. Error -> Eff (console :: CONSOLE | eff) Unit
logError e = error $ show e

module IdePurescript.Atom.Main where

import Prelude
import Control.Promise as Promise
import IdePurescript.Atom.Completion as C
import IdePurescript.Atom.Psci as Psci
import PscIde as P
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (EDITOR, TextEditor, toEditor, onDidSave, getText, getPath, getTextInRange, setTextInBufferRange, setText, getBuffer, getCursorBufferPosition)
import Atom.NotificationManager (NOTIFY, addError)
import Atom.Point (Point, getRow, getColumn, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange, Range, getStart, getEnd)
import Atom.TextBuffer (setTextViaDiff)
import Atom.Workspace (WORKSPACE, onDidChangeActivePaneItem, observeTextEditors, getActiveTextEditor)
import Control.Bind (join)
import Control.Monad (when)
import Control.Monad.Aff (runAff, Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log, error)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF, Ref, readRef, writeRef, newRef)
import Control.Monad.Error.Class (catchError)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT, lift)
import Control.Promise (Promise)
import DOM (DOM)
import DOM.Node.Types (Element)
import Data.Array (length)
import Data.Either (either, Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (readBoolean)
import Data.Function.Eff (mkEffFn1)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import IdePurescript.Atom.Build (AtomLintMessage)
import IdePurescript.Atom.BuildStatus (getBuildStatus)
import IdePurescript.Atom.Config (config)
import IdePurescript.Atom.Hooks.Dependencies (installDependencies)
import IdePurescript.Atom.Hooks.Linter (LinterInternal, LinterIndie, LINTER, register)
import IdePurescript.Atom.Hooks.StatusBar (addLeftTile)
import IdePurescript.Atom.LinterBuild (lint, getProjectRoot)
import IdePurescript.Atom.PromptPanel (addPromptPanel)
import IdePurescript.Atom.PscIdeServer (startServer)
import IdePurescript.Atom.QuickFixes (showQuickFixes)
import IdePurescript.Atom.SelectView (selectListViewStatic, selectListViewDynamic)
import IdePurescript.Atom.Tooltips (registerTooltips, getToken)
import IdePurescript.Modules (State, ImportResult(AmbiguousImport, UpdatedImports), getQualModule, addModuleImport, addExplicitImport, initialModulesState, getModulesForFile, getMainModule)
import IdePurescript.PscIde (getPursuitModuleCompletion, getPursuitCompletion, loadDeps, getAvailableModules, getCompletion, eitherToErr, getLoadedModules)
import Node.ChildProcess (CHILD_PROCESS)
import Node.FS (FS)
import PscIde (NET)
import PscIde.Command (Completion(..))

getSuggestions :: forall eff. State -> { editor :: TextEditor, bufferPosition :: Point }
  -> Eff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Promise (Array C.AtomSuggestion))
getSuggestions state ({editor, bufferPosition}) = Promise.fromAff $ flip catchError (raiseError' []) $ do
  let range = mkRange (mkPoint (getRow bufferPosition) 0) bufferPosition
  line <- liftEff $ getTextInRange editor range
  modules <- getLoadedModules -- getUnqualActiveModules state
  let getQualifiedModule = (flip getQualModule) state
  C.getSuggestions { line, moduleInfo: { modules, getQualifiedModule }}
  where
  raiseError' :: (Array C.AtomSuggestion) -> Error -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Array C.AtomSuggestion)
  raiseError' x e = do
    liftEff $ raiseError e
    pure x

useEditor :: forall eff. (Ref State) -> TextEditor -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE | eff) Unit
useEditor modulesStateRef editor = do
  path <- getPath editor
  text <- getText editor
  let mainModule = getMainModule text
  case mainModule of
    Just m -> runAff logError ignoreError $ do
      loadDeps m
      state <- getModulesForFile path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type MainEff =
  ( command :: COMMAND
  , note :: NOTIFY
  , project :: PROJECT
  , fs :: FS
  , ref :: REF
  , cp :: CHILD_PROCESS
  , console :: CONSOLE
  , config :: CONFIG
  , linter :: LINTER
  , editor :: EDITOR
  , net :: NET
  , workspace :: WORKSPACE
  , avar :: AVAR
  , err :: EXCEPTION
  , dom :: DOM
  )

main :: _
main = do
  atom <- getAtom
  linterIndieRef <- newRef (Nothing :: Maybe LinterIndie)
  modulesState <- newRef (initialModulesState)
  messagesRef <- newRef ([] :: Array AtomLintMessage)
  linterInternalRef <- newRef (Nothing :: Maybe LinterInternal)
  deactivateRef <- newRef (pure unit :: Eff MainEff Unit)
  buildStatusRef <- newRef (Nothing :: Maybe Element)

  let
    doLint :: Eff MainEff Unit
    doLint = do
      root <- getProjectRoot
      linterIndie <- readRef linterIndieRef
      statusElt <- readRef buildStatusRef
      case { root, linterIndie, statusElt } of
        { root: Just root', linterIndie: Just linterIndie', statusElt: Just statusElt' } -> runAff raiseError ignoreError $ do
          messages <- lint atom.config root' linterIndie' statusElt'
          liftEff $ maybe (pure unit) (writeRef messagesRef) messages
          editor <- liftEff $ getActiveTextEditor atom.workspace
          liftEff $ maybe (pure unit) (useEditor modulesState) editor
          pure unit
        _ -> pure unit

    quickFix :: Eff MainEff Unit
    quickFix = do
      messages <- readRef messagesRef
      editor <- getActiveTextEditor atom.workspace
      linter <- readRef linterInternalRef
      case { editor, linter, n: length messages } of
        { editor: Just e, linter: Just l, n } | n > 0 -> showQuickFixes e l messages
        _ -> pure unit

    pursuitSearch :: Eff MainEff Unit
    pursuitSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") getPursuitCompletion 1000
      where
      view {identifier, "type": ty, "module": mod, package} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ " (" ++ package ++ ")
"
         ++ "
"

    pursuitSearchModule :: Eff MainEff Unit
    pursuitSearchModule = selectListViewDynamic view importDialog (Just "module") id getPursuitModuleCompletion 1000
      where
      view {"module": mod, package} =
         "
"
         ++ "
" ++ mod ++ "
"
         ++ "
" ++ package ++ "
"
         ++ "
"
      importDialog :: forall a. {"module" :: String | a} -> Eff MainEff Unit
      importDialog {"module": mod} = selectListViewStatic textView (doImport mod) Nothing ["Import module", "Cancel"]
        where
        textView x = "
" ++ x ++ "
"
        doImport mod x = when (x == "Import module") $ addImport mod

    addModuleImportCmd :: Eff MainEff Unit
    addModuleImportCmd = runAff raiseError ignoreError do
      modules <- getAvailableModules
      liftEff $ selectListViewStatic view addImport Nothing modules
      where
        view x = "
" ++ x ++ "
"

    addExplicitImportCmd :: Eff MainEff Unit
    addExplicitImportCmd = runAff raiseError ignoreError do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      case editor of
        Just ed -> do
          { line, col, pos, range } <- liftEff $ getLinePosition ed
          promptText <- liftEff $ maybe "" _.word <$> getToken ed pos
          res <- addPromptPanel "Identifier" promptText
          maybe (pure unit) (addIdentImport Nothing) res
        Nothing -> pure unit

    addIdentImport :: Maybe String -> String -> Aff MainEff Unit
    addIdentImport moduleName ident = do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      maybe (pure unit) (addIdentImport' moduleName ident) editor

    addIdentImport' :: Maybe String -> String -> TextEditor -> Aff MainEff Unit
    addIdentImport' moduleName ident editor = do
      text <- liftEff $ getText editor
      path <- liftEff $ getPath editor
      state <- liftEff $ readRef modulesState
      { state: newState, result: output} <- addExplicitImport state path text moduleName ident
      liftEff $ writeRef modulesState newState
      liftEff $ case output of
        UpdatedImports out -> do
          buf <- getBuffer editor
          void $ setTextViaDiff buf out
        AmbiguousImport opts -> do
          selectListViewStatic view addImp Nothing (runCompletion <$> opts)
        _ -> pure unit
      where
      runCompletion (Completion obj) = obj
      -- TODO nicer if we can make select view aff-ish
      addImp { identifier, "module'": m } = runAff raiseError ignoreError $ addIdentImport (Just m) identifier
      view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"

    addSuggestionImport :: { editor :: TextEditor, suggestion :: C.AtomSuggestion } -> Aff MainEff Unit
    addSuggestionImport { editor, suggestion: { addImport: Just { mod, identifier, qualifier: Nothing } } } =
      addIdentImport' (Just mod) identifier editor
    addSuggestionImport _ = pure unit

    addImport :: String -> Eff MainEff Unit
    addImport moduleName = do
      maybeEditor <- getActiveTextEditor atom.workspace
      state <- liftEff $ readRef modulesState
      case maybeEditor of
        Nothing -> pure unit
        Just editor -> do
          text <- getText editor
          path <- getPath editor
          runAff raiseError ignoreError $ do
            output <- addModuleImport state path text moduleName
            liftEff $ maybe (pure unit) (void <<< setText editor <<< _.result) output

    localSearch :: Eff MainEff Unit
    localSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") search 50
      where
      search text = do
        state <- liftEff $ readRef modulesState
        modules <- getLoadedModules
        let getQualifiedModule = (flip getQualModule) state
        getCompletion text "" false modules getQualifiedModule

      view {identifier, "type": ty, "module": mod} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ "
"
         ++ "
"

    getLinePosition :: TextEditor -> Eff MainEff { line :: String, col :: Int, pos :: Point, range :: Range }
    getLinePosition ed = do
      pos <- getCursorBufferPosition ed
      let range = mkRange (mkPoint (getRow pos) 0) (mkPoint (getRow pos) 1000)
          col = getColumn pos
      line <- getTextInRange ed range
      pure { line, pos, col, range }

    caseSplit :: Eff MainEff Unit
    caseSplit = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        ty <- MaybeT $ addPromptPanel "Parameter type" ""
        lines <- lift $ eitherToErr $ P.caseSplit line (getColumn $ getStart wordRange) (getColumn $ getEnd wordRange) true ty
        lift $ void $ liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines

    addClause :: Eff MainEff Unit
    addClause = do
      editor <- getActiveTextEditor atom.workspace
      case editor of
        Just ed ->
          runAff raiseError ignoreError $ do
            { line, col, range } <- liftEff $ getLinePosition ed
            lines <- eitherToErr $ P.addClause line true
            liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines
        Nothing -> pure unit

    fixTypo :: Eff MainEff Unit
    fixTypo = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { word, range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        corrections <- lift $ eitherToErr (P.suggestTypos word 2)
        liftEff $ selectListViewStatic view (replaceTypo ed wordRange) Nothing (runCompletion <$> corrections)
        where
          runCompletion (Completion obj) = obj
          replaceTypo ed wordRange { identifier, "module'": module' } =
            runAff raiseError ignoreError do
             liftEff $ setTextInBufferRange ed wordRange identifier
             addIdentImport (Just module') identifier
          view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"
          getIdentFromCompletion (Completion c) = c.identifier

    activate :: Eff MainEff Unit
    activate = do
      let cmd name action = addCommand atom.commands "atom-workspace" ("purescript:"++name) (const action)
      cmd "build" doLint
      cmd "show-quick-fixes" quickFix
      cmd "pursuit-search" pursuitSearch
      cmd "pursuit-search-modules" pursuitSearchModule
      cmd "add-module-import" addModuleImportCmd
      cmd "add-explicit-import" addExplicitImportCmd
      cmd "search" localSearch
      cmd "case-split" caseSplit
      cmd "add-clause" addClause
      cmd "fix-typo" fixTypo

      installDependencies

      observeTextEditors atom.workspace (\editor -> do -- TODO: Check if file is .purs
        useEditor modulesState editor
        onDidSave editor (\_ -> do
          buildOnSave <- getConfig atom.config "ide-purescript.buildOnSave"
          when (either (const false) id $ readBoolean buildOnSave) doLint -- TODO: Check if file is in project
        )
      )

      onDidChangeActivePaneItem atom.workspace (\item ->
        maybe (pure unit) (useEditor modulesState) (toEditor item)
      )

      registerTooltips modulesState
      runAff
        (\_ -> log "Error starting server")
        (\deact -> do
            writeRef deactivateRef deact
            editor <- getActiveTextEditor atom.workspace
            maybe (pure unit) (useEditor modulesState) editor)
        startServer
      Psci.init

    deactivate :: Eff MainEff Unit
    deactivate = join (readRef deactivateRef)

  pure
    { config
    , activate: mkEffFn1 \_ -> activate
    , deactivate: mkEffFn1 \_ -> deactivate
    , consumeLinterIndie: mkEffFn1 \registry -> do
        linterIndie <- register registry {name: "PureScript"}
        writeRef linterIndieRef $ Just linterIndie
    , consumeLinterInternal: mkEffFn1 \linter ->
        writeRef linterInternalRef $ Just linter
    , consumeStatusBar: mkEffFn1 \statusBar -> do
        item <- getBuildStatus
        writeRef buildStatusRef $ Just item
        addLeftTile statusBar { item, priority: -50 }
    , provideAutocomplete: \_ ->
        { selector: ".source.purescript"
        , disableForSelector: ".source.purescript .comment, .source.purescript .string"
        , inclusionPriority: 1
        , excludeLowerPriority: true
        , getSuggestions: mkEffFn1 $ \x -> do
            state <- readRef modulesState
            getSuggestions state x
        , onDidInsertSuggestion: mkEffFn1 \x -> do
            shouldAddImport <- getConfig atom.config "ide-purescript.importOnAutocomplete"
            when (readBoolean shouldAddImport == Right true)
              (runAff raiseError ignoreError $ addSuggestionImport x)
        }
    }

raiseError :: forall eff. Error -> Eff (note :: NOTIFY | eff) Unit
raiseError e = do
  atom <- getAtom
  addError atom.notifications (show e)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

logError :: forall eff. Error -> Eff (console :: CONSOLE | eff) Unit
logError e = error $ show e


Fixed missing qualified.

Fixed missing qualified.

module Graphics.WebGL.Free (
	WebGL(),
	WebGLF()
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Free
import Graphics.Canvas (Canvas())
import qualified Graphics.WebGL.Raw as GL
import Graphics.WebGL.Raw.Types

enable :: forall eff. WebGLContext -> GLenum -> Eff (canvas :: Canvas | eff) Unit
enable webgl cap = runFn2 enableImpl webgl cap

data WebGLF a
	= Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| DepthFunc GLenum a
	| Enable GLenum a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

--viewport :: forall eff. WebGLContext -> GLint -> GLint -> GLsizei -> GLsizei- -> Eff (canvas :: Canvas | eff) Unit
--viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
--viewport = liftF $ Viewport

module Graphics.WebGL.Free (
	WebGL(),
	WebGLF()
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Free
import Graphics.Canvas (Canvas())
import Graphics.WebGL.Raw as GL
import Graphics.WebGL.Raw.Types

enable :: forall eff. WebGLContext -> GLenum -> Eff (canvas :: Canvas | eff) Unit
enable webgl cap = runFn2 enableImpl webgl cap

data WebGLF a
	= Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| DepthFunc GLenum a
	| Enable GLenum a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

--viewport :: forall eff. WebGLContext -> GLint -> GLint -> GLsizei -> GLsizei- -> Eff (canvas :: Canvas | eff) Unit
--viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
--viewport = liftF $ Viewport


Fix pure for MaybeT

Fix pure for MaybeT

module Control.Monad.Maybe.Trans where

import Prelude
import Control.Monad
import Control.Monad.Trans
import Data.Either
import Data.Maybe
import Data.Tuple

data MaybeT m a = MaybeT (m (Maybe a))

instance functorMaybeT :: (Monad m) => Functor (MaybeT m) where
  (<$>) = liftA1

instance applyMaybeT :: (Monad m) => Apply (MaybeT m) where
  (<*>) = ap

instance applicativeMaybeT :: (Monad m) => Applicative (MaybeT m) where
  pure = MaybeT <<< pure <<< Just

instance bindMaybeT :: (Monad m) => Bind (MaybeT m) where
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance monadMaybeT :: (Monad m) => Monad (MaybeT m)

instance monadTransMaybeT :: MonadTrans MaybeT where
  lift = MaybeT <<< liftM1 Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x

mapMaybeT :: forall m1 m2 a b. (m1 (Maybe a) -> m2 (Maybe b)) -> MaybeT m1 a -> MaybeT m2 b
mapMaybeT f = MaybeT <<< f <<< runMaybeT

liftCatchMaybe :: forall m e a. (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) -> MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a
liftCatchMaybe catch m h = MaybeT $ catch (runMaybeT m) (runMaybeT <<< h)

liftListenMaybe :: forall m a w. (Monad m) => (m (Maybe a) -> m (Tuple (Maybe a) w)) -> MaybeT m a -> MaybeT m (Tuple a w)
liftListenMaybe listen = mapMaybeT $ \m -> do
  Tuple a w <- listen m
  return $ (\r -> Tuple r w) <$> a

liftPassMaybe :: forall m a w. (Monad m) => (m (Tuple (Maybe a) (w -> w)) -> m (Maybe a)) -> MaybeT m (Tuple a (w -> w)) -> MaybeT m a
liftPassMaybe pass = mapMaybeT $ \m -> pass $ do
  a <- m
  return $ case a of
    Nothing -> Tuple Nothing id
    Just (Tuple v f) -> Tuple (Just v) f

liftCallCCMaybe :: forall m a b. (((Maybe a -> m (Maybe b)) -> m (Maybe a)) -> m (Maybe a)) -> ((a -> MaybeT m b) -> MaybeT m a) -> MaybeT m a
liftCallCCMaybe callCC f = MaybeT $ callCC $ \c -> runMaybeT (f (\a -> MaybeT $ c $ Just a))

module Control.Monad.Maybe.Trans where

import Prelude
import Control.Monad
import Control.Monad.Trans
import Data.Either
import Data.Maybe
import Data.Tuple

data MaybeT m a = MaybeT (m (Maybe a))

instance functorMaybeT :: (Monad m) => Functor (MaybeT m) where
  (<$>) = liftA1

instance applyMaybeT :: (Monad m) => Apply (MaybeT m) where
  (<*>) = ap

instance applicativeMaybeT :: (Monad m) => Applicative (MaybeT m) where
  pure = return

instance bindMaybeT :: (Monad m) => Bind (MaybeT m) where
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance monadMaybeT :: (Monad m) => Monad (MaybeT m)

instance monadTransMaybeT :: MonadTrans MaybeT where
  lift = MaybeT <<< liftM1 Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x

mapMaybeT :: forall m1 m2 a b. (m1 (Maybe a) -> m2 (Maybe b)) -> MaybeT m1 a -> MaybeT m2 b
mapMaybeT f = MaybeT <<< f <<< runMaybeT

liftCatchMaybe :: forall m e a. (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) -> MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a
liftCatchMaybe catch m h = MaybeT $ catch (runMaybeT m) (runMaybeT <<< h)

liftListenMaybe :: forall m a w. (Monad m) => (m (Maybe a) -> m (Tuple (Maybe a) w)) -> MaybeT m a -> MaybeT m (Tuple a w)
liftListenMaybe listen = mapMaybeT $ \m -> do
  Tuple a w <- listen m
  return $ (\r -> Tuple r w) <$> a

liftPassMaybe :: forall m a w. (Monad m) => (m (Tuple (Maybe a) (w -> w)) -> m (Maybe a)) -> MaybeT m (Tuple a (w -> w)) -> MaybeT m a
liftPassMaybe pass = mapMaybeT $ \m -> pass $ do
  a <- m
  return $ case a of
    Nothing -> Tuple Nothing id
    Just (Tuple v f) -> Tuple (Just v) f

liftCallCCMaybe :: forall m a b. (((Maybe a -> m (Maybe b)) -> m (Maybe a)) -> m (Maybe a)) -> ((a -> MaybeT m b) -> MaybeT m a) -> MaybeT m a
liftCallCCMaybe callCC f = MaybeT $ callCC $ \c -> runMaybeT (f (\a -> MaybeT $ c $ Just a))


Fix fallback module

Fix fallback module

module Neodoc.ArgParser.Fallback (
  getFallbackValue
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.List (List)
import Control.Alt ((<|>))
import Neodoc.Env as Env
import Neodoc.Env (Env ())
import Neodoc.Value as Value
import Neodoc.Value (Value(..))
import Neodoc.Value.Origin as Origin
import Neodoc.Value.Origin (Origin())
import Neodoc.Value.RichValue (RichValue())
import Neodoc.Value.RichValue (from, getOrigin) as RValue
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved

-- import Language.Docopt.Argument (Argument(..), OptionArgument(..)) as D
import Neodoc.Data.Description
import Neodoc.Data.Description as Description
import Neodoc.ArgParser.Options (Options)

-- Find a fallback value for the given argument.
getFallbackValue
  :: ∀ r
   . Options r
  -> Env
  -> Maybe Description
  -> SolvedLayoutArg
  -> Maybe RichValue
getFallbackValue options env mDescription x = do
  (fromEnv       mDescription <#> RValue.from Origin.Environment) <|>
  (fromDefault x mDescription <#> RValue.from Origin.Default)     <|>
  (empty       x              <#> RValue.from Origin.Empty)

  where
  fromEnv :: Maybe Description -> Maybe Value
  fromEnv (Just (OptionDescription _ _ _ _ (Just k))) = StringValue <$> Env.lookup k env
  fromEnv _                                           = Nothing

  fromDefault :: SolvedLayoutArg -> Maybe Description -> Maybe Value
  fromDefault (Option _ _ r) (Just (OptionDescription _ _ _ (Just v) _))
    = pure if r
              then ArrayValue $ Value.intoArray v
              else v
  fromDefault _ _ = Nothing

  empty :: SolvedLayoutArg -> Maybe Value
  empty = go
    where
    go (Option _ Nothing r)
      | not options.requireFlags
      = pure if r then ArrayValue []
                  else BoolValue false
    go (Option _ (Just (Solved.OptionArgument _ true)) r)
      | not options.requireFlags
      = pure if r then ArrayValue []
                  else BoolValue false
    go (Stdin) = pure $ BoolValue false
    go (EOA)   = pure $ ArrayValue []
    go _       = Nothing

module Neodoc.ArgParser.Fallback (
  getFallbackValue
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.List (List)
import Control.Alt ((<|>))
import Neodoc.Env as Env
import Neodoc.Env (Env ())
import Neodoc.Value as Value
import Neodoc.Value (Value(..))
import Neodoc.Value.Origin as Origin
import Neodoc.Value.Origin (Origin())
import Neodoc.Value.RichValue (RichValue())
import Neodoc.Value.RichValue (from, getOrigin) as RValue
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved

-- import Language.Docopt.Argument (Argument(..), OptionArgument(..)) as D
import Neodoc.Data.Description
import Neodoc.Data.Description as Description
import Neodoc.ArgParser.Options (Options)

-- Find a fallback value for the given argument.
getFallbackValue
  :: ∀ r
   . Options r
  -> Env
  -> Maybe Description
  -> SolvedLayoutArg
  -> Maybe RichValue
getFallbackValue options env mDescription x = do
  d <- mDescription
  (fromEnv       d <#> RValue.from Origin.Environment) <|>
  (fromDefault x d <#> RValue.from Origin.Default)     <|>
  (empty       x   <#> RValue.from Origin.Empty)

  where
  fromEnv :: Description -> Maybe Value
  fromEnv (OptionDescription _ _ _ _ (Just k)) = StringValue <$> Env.lookup k env
  fromEnv _                                    = Nothing

  fromDefault :: SolvedLayoutArg -> Description -> Maybe Value
  fromDefault (Option _ _ r) (OptionDescription _ _ _ (Just v) _)
    = pure if r
              then ArrayValue $ Value.intoArray v
              else v
  fromDefault _ _ = Nothing

  empty :: SolvedLayoutArg -> Maybe Value
  empty = go
    where
    go (Option _ Nothing r)
      | not options.requireFlags
      = pure if r then ArrayValue []
                  else BoolValue false
    go (Option _ (Just (Solved.OptionArgument _ true)) r)
      | not options.requireFlags
      = pure if r then ArrayValue []
                  else BoolValue false
    go (Stdin) = pure $ BoolValue false
    go (EOA)   = pure $ ArrayValue []
    go _       = Nothing


Fix parse format for DateTime coming from HTML inputs

{-
Copyright 2017 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.SqlSquared.Tagged where

import SlamData.Prelude

import Data.Array as A
import Data.Int as Int
import Data.Formatter.DateTime as Fd
import Data.DateTime as DT
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Data.String.Regex.Unsafe as URX

import SqlSquared (Sql)
import SqlSquared as Sql

import Utils (stringToNumber, stringToBoolean)

-- Truncate value to only include YYYY-MM-DD part, in case of Quasar mongo
-- connector issue that cannot represent dates distinct from datetimes.
fixupDate ∷ String → String
fixupDate = Str.take 10

parseTime ∷ String → String ⊹ DT.Time
parseTime = map DT.time ∘ Fd.unformatDateTime "HH:mm:ss" ∘ tweak
  where
  tweak ∷ String → String
  tweak s
    | Str.length s ≡ 19 = s <> "Z"
    | Str.charAt 10 s ≡ Just ' ' = tweak (Str.take 10 s <> "T" <> Str.drop 11 s)
    | otherwise = s

parseDate ∷ String → String ⊹ DT.Date
parseDate = map DT.date ∘ Fd.unformatDateTime "YYYY-MM-DD" ∘ fixupDate

parseDateTime ∷ String → String ⊹ DT.DateTime
parseDateTime = Fd.unformatDateTime "YYYY-MM-DDTHH:mm:ssZ" ∘ tweak
  where
  -- The `datetime-local` HTML picker omits the `Z` from the format, so if it's
  -- missing from the input, add it.
  tweak ∷ String → String
  tweak s
    | Str.length s ≡ 19 = s <> "Z"
    | otherwise = s

dateSql ∷ String → Maybe Sql
dateSql s = do
  guard $ isRight $ parseDate s
  pure $ Sql.invokeFunction "DATE" $ pure $ Sql.string s

timeSql ∷ String → Maybe Sql
timeSql s = do
  guard $ isRight $ parseTime s
  pure $ Sql.invokeFunction "TIME" $ pure $ Sql.string s

datetimeSql ∷ String → Maybe Sql
datetimeSql s = do
  guard $ isRight $ parseDateTime s
  pure $ Sql.invokeFunction "TIMESTAMP" $ pure $ Sql.string s

intervalSql ∷ String → Maybe Sql
intervalSql s = do
  guard $ RX.test rgx s
  pure $ Sql.invokeFunction "INTERVAL" $ pure $ Sql.string s
  where
  rgx =
    URX.unsafeRegex
      "P((([0-9]*\\.?[0-9]*)Y)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)W)?(([0-9]*\\.?[0-9]*)D)?)?(T(([0-9]*\\.?[0-9]*)H)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)S)?)?"
      RXF.noFlags

oidSql ∷ String → Sql
oidSql =
  Sql.invokeFunction "OID" ∘ pure ∘ Sql.string

numSql ∷ String → Maybe Sql
numSql s = do
 num ← stringToNumber s
 pure $ Sql.num num

intSql ∷ String → Maybe Sql
intSql s = do
  int ← Int.fromString s
  pure $ Sql.int int

boolSql ∷ String → Maybe Sql
boolSql s = do
  bool ← stringToBoolean s
  pure $ Sql.bool bool

allSqls ∷ String → Array Sql
allSqls s =
  A.mapMaybe (\f → f s)
    [ dateSql, timeSql, datetimeSql, intervalSql, numSql, intSql, boolSql ]

{-
Copyright 2017 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.SqlSquared.Tagged where

import SlamData.Prelude

import Data.Array as A
import Data.Int as Int
import Data.Formatter.DateTime as Fd
import Data.DateTime as DT
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Data.String.Regex.Unsafe as URX

import SqlSquared (Sql)
import SqlSquared as Sql

import Utils (stringToNumber, stringToBoolean)

tweak ∷ String → String
tweak s
  | Str.length s ≡ 19 = s <> "Z"
  | Str.charAt 10 s ≡ Just ' ' = tweak (Str.take 10 s <> "T" <> Str.drop 11 s)
  | otherwise = s

-- Truncate value to only include YYYY-MM-DD part, in case of Quasar mongo
-- connector issue that cannot represent dates distinct from datetimes.
fixupDate ∷ String → String
fixupDate = Str.take 10

parseTime ∷ String → String ⊹ DT.Time
parseTime = map DT.time ∘ Fd.unformatDateTime "HH:mm:ss" ∘ tweak

parseDate ∷ String → String ⊹ DT.Date
parseDate = map DT.date ∘ Fd.unformatDateTime "YYYY-MM-DD" ∘ fixupDate

parseDateTime ∷ String → String ⊹ DT.DateTime
parseDateTime = Fd.unformatDateTime "YYYY-MM-DDTHH:mm:ssZ"

dateSql ∷ String → Maybe Sql
dateSql s = do
  guard $ isRight $ parseDate s
  pure $ Sql.invokeFunction "DATE" $ pure $ Sql.string s

timeSql ∷ String → Maybe Sql
timeSql s = do
  guard $ isRight $ parseTime s
  pure $ Sql.invokeFunction "TIME" $ pure $ Sql.string s

datetimeSql ∷ String → Maybe Sql
datetimeSql s = do
  guard $ isRight $ parseDateTime s
  pure $ Sql.invokeFunction "TIMESTAMP" $ pure $ Sql.string s

intervalSql ∷ String → Maybe Sql
intervalSql s = do
  guard $ RX.test rgx s
  pure $ Sql.invokeFunction "INTERVAL" $ pure $ Sql.string s
  where
  rgx =
    URX.unsafeRegex
      "P((([0-9]*\\.?[0-9]*)Y)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)W)?(([0-9]*\\.?[0-9]*)D)?)?(T(([0-9]*\\.?[0-9]*)H)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)S)?)?"
      RXF.noFlags

oidSql ∷ String → Sql
oidSql =
  Sql.invokeFunction "OID" ∘ pure ∘ Sql.string

numSql ∷ String → Maybe Sql
numSql s = do
 num ← stringToNumber s
 pure $ Sql.num num

intSql ∷ String → Maybe Sql
intSql s = do
  int ← Int.fromString s
  pure $ Sql.int int

boolSql ∷ String → Maybe Sql
boolSql s = do
  bool ← stringToBoolean s
  pure $ Sql.bool bool

allSqls ∷ String → Array Sql
allSqls s =
  A.mapMaybe (\f → f s)
    [ dateSql, timeSql, datetimeSql, intervalSql, numSql, intSql, boolSql ]


Add missing tree traversal functions and complete tree indexing

module AST where

import Prelude
import Control.Monad.State (State, evalState, get, put)
import Data.Bifunctor (bimap, rmap)
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Data.Bitraversable (bisequence)
import Data.Tuple (Tuple(..), fst, snd)

-- | 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))

toOpTuple :: Op -> Tuple Op MType
toOpTuple op = Tuple op Nothing

exprToTypeTree :: Expr -> TypeTree
exprToTypeTree (Atom _ atom) = Atom Nothing atom
exprToTypeTree (List _ exprs) = List Nothing (map exprToTypeTree exprs)
exprToTypeTree (NTuple _ exprs) = NTuple Nothing (map exprToTypeTree exprs)
exprToTypeTree (Binary _ op t1 t2) = Binary Nothing (toOpTuple op)
  (exprToTypeTree t1)
  (exprToTypeTree t2)
exprToTypeTree (Unary _ op t) = Unary Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (SectL _ t op) = SectL Nothing (exprToTypeTree t) (toOpTuple op)
exprToTypeTree (SectR _ op t) = SectR Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (PrefixOp _ op) = PrefixOp Nothing (toOpTuple op)
exprToTypeTree (IfExpr _ t1 t2 t3) = IfExpr Nothing
  (exprToTypeTree t1)
  (exprToTypeTree t2)
  (exprToTypeTree t3)
exprToTypeTree (ArithmSeq _ t1 mt2 mt3) = ArithmSeq Nothing
  (exprToTypeTree t1)
  (map exprToTypeTree mt2)
  (map exprToTypeTree mt3)
exprToTypeTree (LetExpr _ bs t) = LetExpr Nothing
  (map (\(Tuple b bt) -> Tuple (map (const Nothing) b) (exprToTypeTree bt)) bs)
  (exprToTypeTree t)
exprToTypeTree (Lambda _ bindings t) = Lambda Nothing
  (map (map (const Nothing)) bindings)
  (exprToTypeTree t)
exprToTypeTree (App _ t ts) = App Nothing (exprToTypeTree t) (map exprToTypeTree ts)
exprToTypeTree (ListComp _ t qualTrees) = ListComp Nothing
  (exprToTypeTree t)
  (map go qualTrees)
    where
    go (Gen _ b t) = Gen Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Let _ b t) = Let Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Guard _ t) = Guard Nothing (exprToTypeTree t)

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

-- TODO: Find better name.
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) = NTuple (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)

qualTreeMap :: forall b b' t t' m m'.
     (b -> b')
  -> (t -> t')
  -> (m -> m')
  -> QualTree b t m
  -> QualTree b' t' m'
qualTreeMap fb ft f (Gen x b t) = Gen (f x) (fb b) (ft t)
qualTreeMap fb ft f (Let x b t) = Let (f x) (fb b) (ft t)
qualTreeMap fb ft f (Guard x t) = Guard (f x) (ft t)

treeMap :: forall a a' b b' o o' m m'.
     (a -> a')        -- ^ Function applied to the atom element
  -> (b -> b')        -- ^ Function applied to the binding element
  -> (o -> o')        -- ^ Function applied to the operator element
  -> (m -> m')        -- ^ Function applied to the meta element
  -> Tree a b o m     -- ^ Tree to be transformed
  -> Tree a' b' o' m' -- ^ Transformed tree
treeMap fa fb fo f (Atom x a) = Atom (f x) (fa a)
treeMap fa fb fo f (List x es) = List (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (NTuple x es) = NTuple (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (Binary x o e1 e2) =
  Binary (f x) (fo o)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
treeMap fa fb fo f (Unary x o e) = Unary (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (SectL x e o) = SectL (f x) (treeMap fa fb fo f e) (fo o)
treeMap fa fb fo f (SectR x o e) = SectR (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (PrefixOp x o) = PrefixOp (f x) (fo o)
treeMap fa fb fo f (IfExpr x e1 e2 e3) =
  IfExpr (f x)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
    (treeMap fa fb fo f e3)
treeMap fa fb fo f (ArithmSeq x e me1 me2) =
  ArithmSeq (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) me1)
    (map (treeMap fa fb fo f) me2)
treeMap fa fb fo f (LetExpr x defs e) =
  LetExpr (f x)
    (map (bimap fb (treeMap fa fb fo f)) defs)
    (treeMap fa fb fo f e)
treeMap fa fb fo f (Lambda x bs e) = Lambda (f x) (map fb bs) (treeMap fa fb fo f e)
treeMap fa fb fo f (App x e es) =
  App (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (ListComp x e qualTrees) =
  ListComp (f x)
    (treeMap fa fb fo f e)
    (map (qualTreeMap fb (treeMap fa fb fo f) f) qualTrees)

insertIntoTree :: forall a b c d. d -> Tree a b c d -> Tree a b c d
insertIntoTree x (Atom _ atom) = Atom x atom
insertIntoTree x (List _ ts) = List x ts
insertIntoTree x (NTuple _ ts) = NTuple x ts
insertIntoTree x (Binary _ op t1 t2) = Binary x op t1 t2
insertIntoTree x (Unary _ op t) = Unary x op t
insertIntoTree x (SectL _ t op) = SectL x t op
insertIntoTree x (SectR _ op t) = SectR x op t
insertIntoTree x (PrefixOp _ op) = PrefixOp x op
insertIntoTree x (IfExpr _ t1 t2 t3) = IfExpr x t1 t2 t3
insertIntoTree x (ArithmSeq _ t1 t2 t3) = ArithmSeq x t1 t2 t3
insertIntoTree x (LetExpr _ bs t) = LetExpr x bs t
insertIntoTree x (Lambda _ b t) = Lambda x b t
insertIntoTree x (App _ t ts) = App x t ts
insertIntoTree x (ListComp _ t ts) = ListComp x t ts

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

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

extractFromQualTree :: forall b t m. QualTree b t m -> m
extractFromQualTree (Gen x _ _) = x
extractFromQualTree (Let x _ _) = x
extractFromQualTree (Guard x _) = x

type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

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

type Index = Int
type MIType = Tuple MType Index
type IndexedTypeTree = Tree Atom (Binding MIType) (Tuple Op MIType) MIType

makeIndexTuple :: MType -> State Index MIType
makeIndexTuple mt = do
  idx <- get
  let new = Tuple mt idx
  put (idx + 1)
  pure new

makeIndexOpTuple :: (Tuple Op MType) -> State Index (Tuple Op MIType)
makeIndexOpTuple (Tuple op mt) = do
  idx <- get
  let new = Tuple op (Tuple mt idx)
  put (idx + 1)
  pure new

makeIndexedTree :: TypeTree -> IndexedTypeTree
makeIndexedTree expr = evalState (makeIndexedTree' expr) 0
  where
    -- Traverse the tree and assign indices in ascending order.
    makeIndexedTree' :: TypeTree -> State Index IndexedTypeTree
    makeIndexedTree' expr = traverseTree (traverseBinding makeIndexTuple) makeIndexOpTuple makeIndexTuple expr

removeIndices :: IndexedTypeTree -> TypeTree
removeIndices = treeMap id (map fst) (\(Tuple op mit) -> Tuple op (fst mit)) fst

insertIntoIndexedTree :: MType -> IndexedTypeTree -> IndexedTypeTree
insertIntoIndexedTree t expr = insertIntoTree (Tuple t idx) expr
  where idx = snd $ extractFromTree expr

opIndex :: (Tuple Op MIType) -> Index
opIndex (Tuple op (Tuple mt idx)) = idx

index :: IndexedTypeTree -> Index
index = extractFromTree >>> snd

traverseBinding :: forall m m' f. Monad f =>
     (m -> f m')
  -> Binding m
  -> f (Binding m')
traverseBinding f (Lit t atom) = do
  t' <- f t
  pure $ Lit t' atom
traverseBinding f (ConsLit t b1 b2) = do
  t' <- f t
  b1' <- traverseBinding f b1
  b2' <- traverseBinding f b2
  pure $ ConsLit t' b1' b2'
traverseBinding f (ListLit t bs) = do
  t' <- f t
  bs' <- traverse (traverseBinding f) bs
  pure $ ListLit t' bs'
traverseBinding f (NTupleLit t bs) = do
  t' <- f t
  bs' <- traverse (traverseBinding f) bs
  pure $ NTupleLit t' bs'

traverseQualTree :: forall b b' e e' m m' f. Monad f =>
     (b -> f b')
  -> (e -> f e')
  -> (m -> f m')
  -> QualTree b e m
  -> f (QualTree b' e' m')
traverseQualTree fb fe f (Gen t b e) = do
  t' <- f t
  b' <- fb b
  e' <- fe e
  pure $ Gen t' b' e'
traverseQualTree fb fe f (Let t b e) = do
  t' <- f t
  b' <- fb b
  e' <- fe e
  pure $ Let t' b' e'
traverseQualTree fb fe f (Guard t e) = do
  t' <- f t
  e' <- fe e
  pure $ Guard t' e'

traverseTree :: forall b b' o o' m m' f. Monad f =>
     (b -> f b')
  -> (o -> f o')
  -> (m -> f m')
  -> Tree Atom b o m
  -> f (Tree Atom b' o' m')
traverseTree fb fo f expr@(Atom t atom) = do
  t' <- f t
  pure $ Atom t' atom
traverseTree fb fo f expr@(List t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ List t' es'
traverseTree fb fo f expr@(NTuple t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ NTuple t' es'
traverseTree fb fo f expr@(Binary t o e1 e2) = do
  t' <- f t
  o' <- fo o
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  pure $ Binary t' o' e1' e2'
traverseTree fb fo f expr@(Unary t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ Unary t' o' e'
traverseTree fb fo f expr@(SectL t e o) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  o' <- fo o
  pure $ SectL t' e' o'
traverseTree fb fo f expr@(SectR t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ SectR t' o' e'
traverseTree fb fo f expr@(PrefixOp t o) = do
  t' <- f t
  o' <- fo o
  pure $ PrefixOp t' o'
traverseTree fb fo f expr@(IfExpr t e1 e2 e3) = do
  t' <- f t
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  e3' <- traverseTree fb fo f e3
  pure $ IfExpr t' e1' e2' e3'
traverseTree fb fo f expr@(ArithmSeq t e me1 me2) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  me1' <- traverse (traverseTree fb fo f) me1
  me2' <- traverse (traverseTree fb fo f) me2
  pure $ ArithmSeq t' e' me1' me2'
traverseTree fb fo f expr@(LetExpr t defs e) = do
  t' <- f t
  defs' <- traverse (bimap fb (traverseTree fb fo f) >>> bisequence) defs
  e' <- traverseTree fb fo f e
  pure $ LetExpr t' defs' e'
traverseTree fb fo f expr@(Lambda t bs e) = do
  t' <- f t
  bs' <- traverse fb bs
  e' <- traverseTree fb fo f e
  pure $ Lambda t' bs' e'
traverseTree fb fo f expr@(App t e es) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  es' <- traverse (traverseTree fb fo f) es
  pure $ App t' e' es'
-- ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))
traverseTree fb fo f expr@(ListComp t e quals) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  quals' <- traverse (traverseQualTree fb (traverseTree fb fo f) f) quals
  pure $ ListComp t' e' quals'

type ExprQualTree = QualTree (Binding Unit) Expr Unit

type TypeQual  = QualTree (Binding MType) TypeTree MType

type TVar = String

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

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)

-- | 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 (UnknownType) = "(UnknownType)"
  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 (UnknownType) = "?"
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 Control.Monad.State (State, evalState, get, put)
import Data.Bifunctor (bimap, rmap)
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)

-- TODO: Remove
import Partial.Unsafe (unsafeCrashWith)

-- | 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))

toOpTuple :: Op -> Tuple Op MType
toOpTuple op = Tuple op Nothing

exprToTypeTree :: Expr -> TypeTree
exprToTypeTree (Atom _ atom) = Atom Nothing atom
exprToTypeTree (List _ exprs) = List Nothing (map exprToTypeTree exprs)
exprToTypeTree (NTuple _ exprs) = NTuple Nothing (map exprToTypeTree exprs)
exprToTypeTree (Binary _ op t1 t2) = Binary Nothing (toOpTuple op)
  (exprToTypeTree t1)
  (exprToTypeTree t2)
exprToTypeTree (Unary _ op t) = Unary Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (SectL _ t op) = SectL Nothing (exprToTypeTree t) (toOpTuple op)
exprToTypeTree (SectR _ op t) = SectR Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (PrefixOp _ op) = PrefixOp Nothing (toOpTuple op)
exprToTypeTree (IfExpr _ t1 t2 t3) = IfExpr Nothing
  (exprToTypeTree t1)
  (exprToTypeTree t2)
  (exprToTypeTree t3)
exprToTypeTree (ArithmSeq _ t1 mt2 mt3) = ArithmSeq Nothing
  (exprToTypeTree t1)
  (map exprToTypeTree mt2)
  (map exprToTypeTree mt3)
exprToTypeTree (LetExpr _ bs t) = LetExpr Nothing
  (map (\(Tuple b bt) -> Tuple (map (const Nothing) b) (exprToTypeTree bt)) bs)
  (exprToTypeTree t)
exprToTypeTree (Lambda _ bindings t) = Lambda Nothing
  (map (map (const Nothing)) bindings)
  (exprToTypeTree t)
exprToTypeTree (App _ t ts) = App Nothing (exprToTypeTree t) (map exprToTypeTree ts)
exprToTypeTree (ListComp _ t qualTrees) = ListComp Nothing
  (exprToTypeTree t)
  (map go qualTrees)
    where
    go (Gen _ b t) = Gen Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Let _ b t) = Let Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Guard _ t) = Guard Nothing (exprToTypeTree t)

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

-- TODO: Find better name.
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) = NTuple (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)

qualTreeMap :: forall b b' t t' m m'.
     (b -> b')
  -> (t -> t')
  -> (m -> m')
  -> QualTree b t m
  -> QualTree b' t' m'
qualTreeMap fb ft f (Gen x b t) = Gen (f x) (fb b) (ft t)
qualTreeMap fb ft f (Let x b t) = Let (f x) (fb b) (ft t)
qualTreeMap fb ft f (Guard x t) = Guard (f x) (ft t)

treeMap :: forall a a' b b' o o' m m'.
     (a -> a')        -- ^ Function applied to the atom element
  -> (b -> b')        -- ^ Function applied to the binding element
  -> (o -> o')        -- ^ Function applied to the operator element
  -> (m -> m')        -- ^ Function applied to the meta element
  -> Tree a b o m     -- ^ Tree to be transformed
  -> Tree a' b' o' m' -- ^ Transformed tree
treeMap fa fb fo f (Atom x a) = Atom (f x) (fa a)
treeMap fa fb fo f (List x es) = List (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (NTuple x es) = NTuple (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (Binary x o e1 e2) =
  Binary (f x) (fo o)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
treeMap fa fb fo f (Unary x o e) = Unary (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (SectL x e o) = SectL (f x) (treeMap fa fb fo f e) (fo o)
treeMap fa fb fo f (SectR x o e) = SectR (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (PrefixOp x o) = PrefixOp (f x) (fo o)
treeMap fa fb fo f (IfExpr x e1 e2 e3) =
  IfExpr (f x)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
    (treeMap fa fb fo f e3)
treeMap fa fb fo f (ArithmSeq x e me1 me2) =
  ArithmSeq (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) me1)
    (map (treeMap fa fb fo f) me2)
treeMap fa fb fo f (LetExpr x defs e) =
  LetExpr (f x)
    (map (bimap fb (treeMap fa fb fo f)) defs)
    (treeMap fa fb fo f e)
treeMap fa fb fo f (Lambda x bs e) = Lambda (f x) (map fb bs) (treeMap fa fb fo f e)
treeMap fa fb fo f (App x e es) =
  App (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (ListComp x e qualTrees) =
  ListComp (f x)
    (treeMap fa fb fo f e)
    (map (qualTreeMap fb (treeMap fa fb fo f) f) qualTrees)

insertIntoTree :: forall a b c d. d -> Tree a b c d -> Tree a b c d
insertIntoTree x (Atom _ atom) = Atom x atom
insertIntoTree x (List _ ts) = List x ts
insertIntoTree x (NTuple _ ts) = NTuple x ts
insertIntoTree x (Binary _ op t1 t2) = Binary x op t1 t2
insertIntoTree x (Unary _ op t) = Unary x op t
insertIntoTree x (SectL _ t op) = SectL x t op
insertIntoTree x (SectR _ op t) = SectR x op t
insertIntoTree x (PrefixOp _ op) = PrefixOp x op
insertIntoTree x (IfExpr _ t1 t2 t3) = IfExpr x t1 t2 t3
insertIntoTree x (ArithmSeq _ t1 t2 t3) = ArithmSeq x t1 t2 t3
insertIntoTree x (LetExpr _ bs t) = LetExpr x bs t
insertIntoTree x (Lambda _ b t) = Lambda x b t
insertIntoTree x (App _ t ts) = App x t ts
insertIntoTree x (ListComp _ t ts) = ListComp x t ts

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

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

extractFromQualTree :: forall b t m. QualTree b t m -> m
extractFromQualTree (Gen x _ _) = x
extractFromQualTree (Let x _ _) = x
extractFromQualTree (Guard x _) = x

type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

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

type Index = Int
type MIType = Tuple MType Index
-- TODO: Change to
type IndexTypeTree = Tree Atom (Binding MIType) (Tuple Op MIType) MIType
type IndexedTypeTree = Tree Atom (Binding MType) (Tuple Op MIType) MIType

makeIndexTuple :: MType -> State Index MIType
makeIndexTuple mt = do
  idx <- get
  let new = Tuple mt idx
  put (idx + 1)
  pure new

makeIndexOpTuple :: (Tuple Op MType) -> State Index (Tuple Op MIType)
makeIndexOpTuple (Tuple op mt) = do
  idx <- get
  let new = Tuple op (Tuple mt idx)
  put (idx + 1)
  pure new

makeIndexedTree :: TypeTree -> IndexedTypeTree
makeIndexedTree expr = evalState (makeIndexedTree' expr) 0
  where
    -- Traverse the tree and assign indices in ascending order.
    makeIndexedTree' :: TypeTree -> State Index IndexedTypeTree
    makeIndexedTree' expr = traverseTree pure makeIndexOpTuple makeIndexTuple expr

removeIndices :: IndexedTypeTree -> TypeTree
removeIndices = treeMap id id (\(Tuple op mit) -> Tuple op (fst mit)) fst

insertIntoIndexedTree :: MType -> IndexedTypeTree -> IndexedTypeTree
insertIntoIndexedTree t expr = insertIntoTree (Tuple t index) expr
  where index = snd $ extractFromTree expr

opIndex :: (Tuple Op MIType) -> Index
opIndex (Tuple op (Tuple mt idx)) = idx

index :: IndexedTypeTree -> Index
index = extractFromTree >>> snd

traverseTree :: forall b b' o o' m m' f. Monad f =>
     (b -> f b')
  -> (o -> f o')
  -> (m -> f m')
  -> Tree Atom b o m
  -> f (Tree Atom b' o' m')
traverseTree fb fo f expr@(Atom t atom) = do
  t' <- f t
  pure $ Atom t' atom
traverseTree fb fo f expr@(List t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ List t' es'
traverseTree fb fo f expr@(NTuple t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ NTuple t' es'
traverseTree fb fo f expr@(Binary t o e1 e2) = do
  t' <- f t
  o' <- fo o
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  pure $ Binary t' o' e1' e2'
traverseTree fb fo f expr@(Unary t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ Unary t' o' e'
traverseTree fb fo f expr@(SectL t e o) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  o' <- fo o
  pure $ SectL t' e' o'
traverseTree fb fo f expr@(SectR t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ SectR t' o' e'
traverseTree fb fo f expr@(PrefixOp t o) = do
  t' <- f t
  o' <- fo o
  pure $ PrefixOp t' o'
traverseTree fb fo f expr@(IfExpr t e1 e2 e3) = do
  t' <- f t
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  e3' <- traverseTree fb fo f e3
  pure $ IfExpr t' e1' e2' e3'
traverseTree fb fo f expr@(ArithmSeq t e me1 me2) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  me1' <- traverse (traverseTree fb fo f) me1
  me2' <- traverse (traverseTree fb fo f) me2
  pure $ ArithmSeq t' e' me1' me2'
traverseTree fb fo f expr@(LetExpr t defs e) = unsafeCrashWith "not yet implemented"
traverseTree fb fo f expr@(Lambda t bs e) = unsafeCrashWith "not yet implemented"
traverseTree fb fo f expr@(App t e es) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  es' <- traverse (traverseTree fb fo f) es
  pure $ App t' e' es'
traverseTree fb fo f expr@(ListComp t e quals) = unsafeCrashWith "not yet implemented"

type ExprQualTree = QualTree (Binding Unit) Expr Unit

type TypeQual  = QualTree (Binding MType) TypeTree MType

type TVar = String

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

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)

-- | 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 (UnknownType) = "(UnknownType)"
  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 (UnknownType) = "?"
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