path fix

path fix

module Driver.File.Path
  ( extractDir
  , updateSort
  , updateQ
  , updateSalt
  , setSort
  , updatePath
  , renderPath
  ) where

import Data.Array (reverse, filter, take, (!!), drop, intersect, length)
import Data.DOM.Simple.Encode (encodeURIComponent, decodeURIComponent)
import Data.Either (either)
import Data.Maybe
import Data.Path.Pathy
import Driver.File.Search (searchPath)
import Model.Resource
import Model.Sort (Sort(..), sort2string)
import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import Text.SlamSearch (mkQuery)
import Text.SlamSearch.Parser.Tokens (keyChars)
import Utils (endsWith, trimQuotes)

sortRgx :: Rgx.Regex
sortRgx = Rgx.regex "(sort=)([^/&]*)" Rgx.noFlags

qRgx :: Rgx.Regex
qRgx = Rgx.regex "(q=)([^/&]*)" Rgx.noFlags

saltRgx :: Rgx.Regex
saltRgx = Rgx.regex "(salt=)([^/&]*)" Rgx.noFlags

updateSort :: Sort -> String -> String
updateSort sort =
  Rgx.replace sortRgx res
  where res = "$1" <> sort2string sort

updateQ :: String -> String -> String
updateQ q =
  Rgx.replace qRgx res
  where res = "$1" <> encodeURIComponent q

updateSalt :: String -> String -> String
updateSalt salt old =
  if attempt /= old then attempt
  else updateSalt (salt <> salt) old
  where attempt = Rgx.replace saltRgx res old
        res = "$1" <> salt

setSort :: Sort -> String
setSort sort = "?sort=" <> sort2string sort <> "&q=&salt="

extractDir :: String -> DirPath
extractDir hash =
  maybe rootDir (rootDir </>) (parseAbsDir (getPath' hash) >>= sandbox rootDir)

getPath' :: String -> String
getPath' hash =
  fromMaybe "" do
    matches <- Rgx.match qRgx hash
    q <- decodeURIComponent <$> matches !! 2
    query <- either (const Nothing) Just (mkQuery q)
    searchPath query

updatePath :: AnyPath -> String -> String
updatePath path hash =
  let pathOld = "path:" <> getPath' hash
      pathNew = "path:" <> renderPath path
      replaced = Str.replace pathOld pathNew hash
  in if replaced == hash then
       updateQ pathNew hash
     else replaced

renderPath :: AnyPath -> String
renderPath ap =
  if 0 == (length $ intersect (Str.split "" rendered) (" ":keyChars))
  then rendered
  else "\"" <> rendered <> "\""
  where
  rendered = either renderFile renderDir ap
  renderDir path =
    printPath $ canonicalize $ maybe rootDir (rootDir </>) (sandbox rootDir path)

  renderFile path =
    printPath $ canonicalize $
    maybe (rootDir </> file "") (rootDir </>) (sandbox rootDir path)

module Driver.File.Path
  ( extractDir
  , updateSort
  , updateQ
  , updateSalt
  , setSort
  , updatePath
  , renderPath
  ) where

import Data.Array (reverse, filter, take, (!!), drop)
import Data.DOM.Simple.Encode (encodeURIComponent, decodeURIComponent)
import Data.Either (either)
import Data.Maybe
import Data.Path.Pathy
import Driver.File.Search (searchPath)
import Model.Resource
import Model.Sort (Sort(..), sort2string)
import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import Text.SlamSearch (mkQuery)
import Utils (endsWith, trimQuotes)

sortRgx :: Rgx.Regex
sortRgx = Rgx.regex "(sort=)([^/&]*)" Rgx.noFlags

qRgx :: Rgx.Regex
qRgx = Rgx.regex "(q=)([^/&]*)" Rgx.noFlags

saltRgx :: Rgx.Regex
saltRgx = Rgx.regex "(salt=)([^/&]*)" Rgx.noFlags

updateSort :: Sort -> String -> String
updateSort sort =
  Rgx.replace sortRgx res
  where res = "$1" <> sort2string sort

updateQ :: String -> String -> String
updateQ q =
  Rgx.replace qRgx res
  where res = "$1" <> encodeURIComponent q

updateSalt :: String -> String -> String
updateSalt salt old =
  if attempt /= old then attempt
  else updateSalt (salt <> salt) old
  where attempt = Rgx.replace saltRgx res old
        res = "$1" <> salt

setSort :: Sort -> String
setSort sort = "?sort=" <> sort2string sort <> "&q=&salt="

extractDir :: String -> DirPath
extractDir hash =
  maybe rootDir (rootDir </>) (parseAbsDir (getPath' hash) >>= sandbox rootDir)

getPath' :: String -> String
getPath' hash =
  fromMaybe "" do
    matches <- Rgx.match qRgx hash
    q <- decodeURIComponent <$> matches !! 2
    query <- either (const Nothing) Just (mkQuery q)
    searchPath query

updatePath :: AnyPath -> String -> String
updatePath path hash =
  let pathOld = "path:" <> getPath' hash
      pathNew = "path:" <> renderPath path
      replaced = Str.replace pathOld pathNew hash
  in if replaced == hash then
       updateQ pathNew hash
     else replaced

renderPath :: AnyPath -> String
renderPath ap =
  if Str.indexOf " " rendered == -1
  then rendered
  else "\"" <> rendered <> "\""
  where
  rendered = either renderFile renderDir ap
  renderDir path =
    printPath $ canonicalize $ maybe rootDir (rootDir </>) (sandbox rootDir path)

  renderFile path =
    printPath $ canonicalize $
    maybe (rootDir </> file "") (rootDir </>) (sandbox rootDir path)


Made Show instances for application state newtypes more consistent.

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = scale (-1.0) k3
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = scale (-1.0) i3
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * angleFromVelocity angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale movementRate $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState{yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "{w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = scale (-1.0) k3
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = scale (-1.0) i3
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * angleFromVelocity angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale movementRate $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p


Stop using .values[0] in FFI for Marker

Stop using .values[0] in FFI for Marker

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module GMaps.Marker where

import Control.Monad.Eff
import GMaps.LatLng
import GMaps.Map

data MarkerOptions = MarkerOptions
  { position :: LatLng
  , map :: Map
  , title :: String
  }

foreign import data Marker :: *

type MarkerOptionsR = { position :: LatLng
                      , map :: Map
                      , title :: String
                      }

runMarkerOptions :: MarkerOptions -> MarkerOptionsR
runMarkerOptions (MarkerOptions o) = { position: o.position
                                     , map: o.map
                                     , title: o.title
                                     }

foreign import newMarkerFFI
  "function newMarkerFFI(opts) {\
  \  return function() {\
  \    return new google.maps.Marker(opts);\
  \  };\
  \}" :: forall eff. MarkerOptionsR -> Eff eff Marker

newMarker :: forall eff. MarkerOptions -> Eff eff Marker
newMarker opts = newMarkerFFI (runMarkerOptions opts)

foreign import setMarkerPosition
  "function setMarkerPosition(marker) {\
  \  return function(latlng) {\
  \    return function() {\
  \      return marker.setPosition(latlng);\
  \    };\
  \  };\
  \}" :: forall eff. MarkerOptions -> Eff eff {}

module GMaps.Marker where

import Control.Monad.Eff
import GMaps.LatLng
import GMaps.Map

data MarkerOptions = MarkerOptions
  { position :: LatLng
  , map :: Map
  , title :: String
  }

data Marker

foreign import newMarker
  "function newMarker(opts) {\
  \  return function() {\
  \    return new google.maps.Marker(opts.values[0]);\
  \  };\
  \}" :: forall eff. MarkerOptions -> Eff eff Marker

foreign import setMarkerPosition
  "function setMarkerPosition(marker) {\
  \  return function(latlng) {\
  \    return function() {\
  \      return marker.setPosition(latlng);\
  \    };\
  \  };\
  \}" :: forall eff. MarkerOptions -> Eff eff {}


Fix unsafeAttribute

Fix unsafeAttribute

module Thermite.Internal where

import DOM

import Data.Maybe

import Control.Monad.Eff

import Thermite.Types

foreign import getStateImpl """
  function getStateImpl(ctx) {
    return function() {
      return ctx.state;
    };
  }
  """ :: forall eff state props action. Context state props action -> Eff eff state

foreign import setStateImpl """
  function setStateImpl(ctx) {
    return function(state) {
      return function() {
        ctx.setState(state);
      };
    };
  }
  """ :: forall eff state props action. Context state props action -> state -> Eff eff Unit

foreign import textImpl """
  function textImpl(s) {
    return s;
  }
  """ :: forall action. String -> Html action

foreign import createElementImpl """
  function createElementImpl(name) {
    return function(attr) {
      return function(children) {
        return React.createElement(name, attr, children);
      };
    };
  }
  """ :: forall action. String -> Attr action -> [Html action] -> Html action

foreign import unsafeAttribute """
  function unsafeAttribute(k) {
    return function(value) {
      var o = {};
      o[k] = value;
      return o;
    };
  }
  """ :: forall action attr. String -> attr -> Attr action

foreign import event """
  function event(name) {
    return function(context) {
      return function(f) {
        var o = {};
        o[name] = function(e) {
          context.performAction(f(e));
        };
        return o;
      };
    };
  }
  """ :: forall state props action event. String -> Context state props action -> (event -> action) -> Attr action

foreign import createClassImpl """
  function createClassImpl(runAction) {
    return function(maybe) {
      return function(spec) {
        return React.createClass({
          getInitialState: function() {
            return spec.initialState;
          },
          performAction: function(action) {
            runAction(this)(spec.performAction(this.props)(action))();
          },
          render: function() {
            return spec.render(this)(this.state)(this.props);
          },
          componentWillMount: function() {
            var self = this;
            maybe(function() { })(function(action) {
              return function() {
                self.performAction(action);
              };
            })(spec.componentWillMount)();
          },
          displayName: maybe(undefined)(function(a) { return a; })(spec.displayName)
        })
      };
    };
  }
  """ :: forall eff m state props action. (Context state props action -> m Unit -> Eff eff Unit) ->
                                          (forall a r. r -> (a -> r) -> Maybe a -> r) ->
                                          Spec m state props action ->
                                          ComponentClass props eff

foreign import documentBody """
  function documentBody(component) {
    return document.body;
  }
  """ :: forall props eff. Eff (dom :: DOM | eff) Node

foreign import renderToImpl """
  function renderToImpl(element) {
    return function (component) {
      return function(props) {
        return function() {
          React.render(React.createElement(component, props), element);
        };
      };
    }
  }
  """ :: forall props eff. Node -> ComponentClass props eff -> props -> Eff (dom :: DOM | eff) Unit

module Thermite.Internal where

import DOM

import Data.Maybe

import Control.Monad.Eff

import Thermite.Types

foreign import getStateImpl """
  function getStateImpl(ctx) {
    return function() {
      return ctx.state;
    };
  }
  """ :: forall eff state props action. Context state props action -> Eff eff state

foreign import setStateImpl """
  function setStateImpl(ctx) {
    return function(state) {
      return function() {
        ctx.setState(state);
      };
    };
  }
  """ :: forall eff state props action. Context state props action -> state -> Eff eff Unit

foreign import textImpl """
  function textImpl(s) {
    return s;
  }
  """ :: forall action. String -> Html action

foreign import createElementImpl """
  function createElementImpl(name) {
    return function(attr) {
      return function(children) {
        return React.createElement(name, attr, children);
      };
    };
  }
  """ :: forall action. String -> Attr action -> [Html action] -> Html action

foreign import unsafeAttribute """
  function unsafeAttribute(attr) {
    return function(value) {
      var o = {};
      o.attr = value;
      return o;
    };
  }
  """ :: forall action attr. String -> attr -> Attr action

foreign import event """
  function event(name) {
    return function(context) {
      return function(f) {
        var o = {};
        o[name] = function(e) {
          context.performAction(f(e));
        };
        return o;
      };
    };
  }
  """ :: forall state props action event. String -> Context state props action -> (event -> action) -> Attr action

foreign import createClassImpl """
  function createClassImpl(runAction) {
    return function(maybe) {
      return function(spec) {
        return React.createClass({
          getInitialState: function() {
            return spec.initialState;
          },
          performAction: function(action) {
            runAction(this)(spec.performAction(this.props)(action))();
          },
          render: function() {
            return spec.render(this)(this.state)(this.props);
          },
          componentWillMount: function() {
            var self = this;
            maybe(function() { })(function(action) {
              return function() {
                self.performAction(action);
              };
            })(spec.componentWillMount)();
          },
          displayName: maybe(undefined)(function(a) { return a; })(spec.displayName)
        })
      };
    };
  }
  """ :: forall eff m state props action. (Context state props action -> m Unit -> Eff eff Unit) ->
                                          (forall a r. r -> (a -> r) -> Maybe a -> r) ->
                                          Spec m state props action ->
                                          ComponentClass props eff

foreign import documentBody """
  function documentBody(component) {
    return document.body;
  }
  """ :: forall props eff. Eff (dom :: DOM | eff) Node

foreign import renderToImpl """
  function renderToImpl(element) {
    return function (component) {
      return function(props) {
        return function() {
          React.render(React.createElement(component, props), element);
        };
      };
    }
  }
  """ :: forall props eff. Node -> ComponentClass props eff -> props -> Eff (dom :: DOM | eff) Unit


Use traverse instead of mapM

Use traverse instead of mapM

module Data.Foreign
  ( Foreign(..)
  , ForeignParser(ForeignParser)
  , parseForeign
  , parseJSON
  , ReadForeign
  , read
  , prop
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Data.Traversable

foreign import data Foreign :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String Foreign

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String a

foreign import readMaybeImpl
  "function readMaybeImpl (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. Foreign -> Maybe Foreign

foreign import readPropImpl
  "function readPropImpl (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String Foreign

foreign import showForeignImpl
  "var showForeignImpl = JSON.stringify;" :: Foreign -> String

instance showForeign :: Prelude.Show Foreign where
  show = showForeignImpl

data ForeignParser a = ForeignParser (Foreign -> Either String a)

parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
parseForeign (ForeignParser p) x = p x

parseJSON :: forall a. (ReadForeign a) => String -> Either String a
parseJSON json = fromString json >>= parseForeign read

instance monadForeignParser :: Prelude.Monad ForeignParser where
  return x = ForeignParser \_ -> Right x
  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
      Left err -> Left err
      Right x' -> parseForeign (f x') x

instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
  pure x = ForeignParser \_ -> Right x
  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorForeignParser :: Prelude.Functor ForeignParser where
  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x

class ReadForeign a where
  read :: ForeignParser a

instance readString :: ReadForeign String where
  read = ForeignParser $ readPrimType "String"

instance readNumber :: ReadForeign Number where
  read = ForeignParser $ readPrimType "Number"

instance readBoolean :: ReadForeign Boolean where
  read = ForeignParser $ readPrimType "Boolean"

instance readArray :: (ReadForeign a) => ReadForeign [a] where
  read =
    let arrayItem (Tuple i x) = case parseForeign read x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (ForeignParser $ readPrimType "Array") >>= \xs ->
      ForeignParser \_ -> arrayItem `traverse` (zip (range 0 (length xs)) xs)

instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
  read = (ForeignParser $ Right <<< readMaybeImpl) >>= \x ->
    ForeignParser \_ -> case x of
      Just x' -> parseForeign read x' >>= return <<< Just
      Nothing -> return Nothing

prop :: forall a. (ReadForeign a) => String -> ForeignParser a
prop p = (ForeignParser \x -> readPropImpl p x) >>= \x ->
  ForeignParser \_ -> case parseForeign read x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

module Data.Foreign
  ( Foreign(..)
  , ForeignParser(ForeignParser)
  , parseForeign
  , parseJSON
  , ReadForeign
  , read
  , prop
  ) where

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

foreign import data Foreign :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String Foreign

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String a

foreign import readMaybeImpl
  "function readMaybeImpl (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. Foreign -> Maybe Foreign

foreign import readPropImpl
  "function readPropImpl (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String Foreign

foreign import showForeignImpl
  "var showForeignImpl = JSON.stringify;" :: Foreign -> String

instance showForeign :: Prelude.Show Foreign where
  show = showForeignImpl

data ForeignParser a = ForeignParser (Foreign -> Either String a)

parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
parseForeign (ForeignParser p) x = p x

parseJSON :: forall a. (ReadForeign a) => String -> Either String a
parseJSON json = fromString json >>= parseForeign read

instance monadForeignParser :: Prelude.Monad ForeignParser where
  return x = ForeignParser \_ -> Right x
  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
      Left err -> Left err
      Right x' -> parseForeign (f x') x

instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
  pure x = ForeignParser \_ -> Right x
  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorForeignParser :: Prelude.Functor ForeignParser where
  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x

class ReadForeign a where
  read :: ForeignParser a

instance readString :: ReadForeign String where
  read = ForeignParser $ readPrimType "String"

instance readNumber :: ReadForeign Number where
  read = ForeignParser $ readPrimType "Number"

instance readBoolean :: ReadForeign Boolean where
  read = ForeignParser $ readPrimType "Boolean"

instance readArray :: (ReadForeign a) => ReadForeign [a] where
  read =
    let arrayItem (Tuple i x) = case parseForeign read x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (ForeignParser $ readPrimType "Array") >>= \xs ->
      ForeignParser \_ -> arrayItem `mapM` (zip (range 0 (length xs)) xs)

instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
  read = (ForeignParser $ Right <<< readMaybeImpl) >>= \x ->
    ForeignParser \_ -> case x of
      Just x' -> parseForeign read x' >>= return <<< Just
      Nothing -> return Nothing

prop :: forall a. (ReadForeign a) => String -> ForeignParser a
prop p = (ForeignParser \x -> readPropImpl p x) >>= \x ->
  ForeignParser \_ -> case parseForeign read x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err


Add tests for normalization of binding expressions

module Test.TypeChecker where

import AST
import TypeChecker as TC
import TypeChecker (charType, emptyTypeEnv, intType, intToIntType)
import Parser (parseExpr, parseDefs)
import Test.Parser (parsedPrelude)

import Prelude (Unit, bind, map, pure, show, unit, ($), (==), (<<<), (<>), (>>=))
import Control.Monad.Writer (Writer, tell)
import Data.Array as Array
import Data.Either (Either(..))
import Data.List (List(..), (:), singleton)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Text.Parsing.Parser (ParseError, parseErrorMessage)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

-- | Construct a list of type [typCon] given the name of the type constants.
typConList :: String -> Type
typConList name = AD $ TList (TypCon name)

-- | Construct a tuple type given a list of type constant names.
typConNTuple:: List String -> Type
typConNTuple names = AD $ TTuple (map TypCon names)

-- | Construct a tuple type given a list of type variable names.
typVarTuple :: List TVar -> Type
typVarTuple tvs = AD $ TTuple (map TypVar tvs)

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = AD $ TList (TypVar tv)

-- | Generate an arrow type from two given type variable names.
typVarArrow :: TVar -> TVar -> Type
typVarArrow tv1 tv2 = TypVar tv1 `TypArr` TypVar tv2

-- | The type (Char, Int, Int)
charIntTupleType :: Type
charIntTupleType = typConNTuple ("Char" : "Int" : "Int" : Nil)

-- | The type (Int, Int)
intTupleType :: Type
intTupleType = typConNTuple ("Int" : "Int" : Nil)

-- | The type [Int]
intList :: Type
intList = AD $ TList $ TypCon "Int"

-- | Report a parse error.
reportParseError :: String -> ParseError -> Writer (List String) Unit
reportParseError testName parseError = tell' $ "Parse error for test case "
  <> testName <> ": "
  <> parseErrorMessage parseError
  <> "\nNote that this is not a failing test but rather an error in the test definition."

-- | Report a type error.
reportTypeError :: String -> TypeError -> Writer (List String) Unit
reportTypeError testName typeError = tell' $ "Type inference failed in test case `"
  <> testName <> "`:\n"
  <> "Encountered type error: "
  <> prettyPrintTypeError typeError

-- | Compare the given two types and report an error if they are not equal.
compareTypes :: String -> Type -> Type -> Writer (List String) Unit
compareTypes testName expected actual = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type: " <> prettyPrintType expected <> "\n" <>
               "Actual type: " <> prettyPrintType actual

-- | Try to infer the type of a given expression and compare the result with the expected type.
testInferExpr :: String -> String -> Type -> Writer (List String) Unit
testInferExpr name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType expression) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  where
  inferAndConvertToType expr = TC.inferTypeNew expr >>= TC.schemeToType

-- | Try to infer the type of a given expression and expect a type error to occur.
testInferExprFail :: String -> String -> TypeError -> Writer (List String) Unit
testInferExprFail name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType expression) of
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
    Left typeError -> if typeError == expected
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type error: " <> prettyPrintTypeError typeError <> "\n" <>
                   "Actual type error: " <> prettyPrintTypeError expected <> "\n"
  where
  inferAndConvertToType expr = TC.inferTypeNew expr >>= TC.schemeToType

testInferDef :: String -> String -> Type -> Writer (List String) Unit
testInferDef name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType def) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.inferDefinitionToScheme def >>= TC.schemeToType

testInferDefFail :: String -> String -> TypeError -> Writer (List String) Unit
testInferDefFail name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType def) of
    Left typeError -> if typeError == expected
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type error: " <> prettyPrintTypeError typeError <> "\n" <>
                   "Actual type error: " <> prettyPrintTypeError expected <> "\n"
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.inferDefinitionToScheme def >>= TC.schemeToType

testInferDefGroup :: String -> String -> Type -> Writer (List String) Unit
testInferDefGroup name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right definitions -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType definitions) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  where
  inferAndConvertToType defs = TC.inferDefinitions defs >>= TC.schemeToType

-- | Infer the type of the given expression in the context of the prelude.
testInferExprWithPrelude :: String -> String -> Type -> Writer (List String) Unit
testInferExprWithPrelude name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.inferTypeInContext parsedPrelude expression of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t

-- | Test type inference on expression trees, given an expression string as well as the expected
-- | resulting typed tree.
testInferTT' :: String -> String -> TypeTree -> Writer (List String) Unit
testInferTT' name unparsedTree expectedTypeTree = case parseExpr unparsedTree of
  Left parseError -> reportParseError name parseError
  Right expression -> testInferTT name expression expectedTypeTree

-- | Test type inference on expression trees. Here not only the expected type of the whole
-- | expression is checked, but also the type of every subexpression.
testInferTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testInferTT name untypedTree expectedTypedTree =
  case TC.inferTypeTreeInContext parsedPrelude untypedTree of
    Left typeError -> reportTypeError name typeError
    Right typedTree -> if expectedTypedTree == typedTree
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                   "Actual type tree: " <> show typedTree <> "\n"

-- | Test type tree normalization.
testNormalizeTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testNormalizeTT name tt normalizedTT = if (TC.normalizeTypeTree tt) == normalizedTT
  then pure unit
  else tell' $ "Type tree normalization failed in test case `" <> name <> "`:\n" <>
               "Expected type tree: " <> show normalizedTT <> "\n" <>
               "Actual type tree: " <> show tt <> "\n"

-- | Typed type tree representing `[1]`.
listOne :: TypeTree
listOne = List (Just $ typConList "Int") (Atom (Just $ TypCon "Int") (AInt 1) : Nil)

-- | Untyped type tree representing `[1]`.
untypedListOne :: TypeTree
untypedListOne = List Nothing (Atom Nothing (AInt 1) : Nil)

runTests :: Writer (List String) Unit
runTests = do

  -- +--------------------------------------------------+
  -- | Test the inferred types of arbitrary expressions |
  -- +--------------------------------------------------+

  -- (3^) :: Int -> Int
  testInferExpr "SectL" "(3^)" intToIntType
  -- (^3) :: Int -> Int
  testInferExpr "SectR" "(^3)" intToIntType
  -- (\a b c d -> a b c d) :: (a -> b -> c -> d) -> a -> b -> c -> d
  testInferExpr "Lambda1" "\\a b c d -> a b c d"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` TypVar "d"))) `TypArr`
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` (TypVar "d")))))
  testInferExpr "Lambda2" "\\a b -> a b"
    (TypArr (TypArr (TypVar "a") (TypVar "b")) (TypArr (TypVar "a") (TypVar "b")))
  testInferExpr "List1" "[1, 2, 3, 4, 5]" intList
  testInferExpr "List2" "[1 + 2, 3 + 4]" intList
  testInferExpr "Empty list" "[]" (typVarList "a")
  testInferExpr "Append" "[1 + 2, 3 + 4] ++ []" intList
  testInferExpr "NTuple" "(1 + 2, 3)" (typConNTuple ("Int" : "Int" : Nil))
  testInferExpr "SectR colon" "(:[3])" (TypCon "Int" `TypArr` intList)
  testInferExpr "Lambda wildcard" "\\_ _ -> 5" (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Lambda cons binding" "\\(x:xs) -> x" (typVarList "a" `TypArr` TypVar "a")
  testInferExpr "Let expression" "let x = 3 in \\_ _ -> x"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Binding tuple in let expression" "let (a, b) = (\\f -> f, \"Hello\") in a b"
    (typConList "Char")
  testInferExpr "Lambda application" "(\\f a b -> f a b) (+) 3 4" intType
  -- ((\xs -> [ x | x <- xs ]) [1]) :: [Int]
  testInferExpr "List comprehension inside lambda" "(\\xs -> [ x | x <- xs ]) [1]" intList

  -- TODO:
  -- testInferExprFail "List3" "[(+), 4]" (UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))
  -- testInferExprFail "Colon" "3 : [1 + 2, 3 + 4, \"Hallo\"]" (Left ((UnificationFail (AD $ TList $ TypCon "Char") (TypCon "Int"))))

  -- +-----------------------------------------------+
  -- | Test the inferred types of single definitions |
  -- +-----------------------------------------------+

  testInferDef "Define app" "app f xs = app f xs"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c"))
  testInferDef "Define single map" "map f (x:xs) = f x : map f xs"
    ((TypVar "a" `TypArr` TypVar "b") `TypArr` (typVarList "a" `TypArr` typVarList "b"))
  testInferDef "Define foldr" "foldr f ini (x:xs) = f x (foldr f ini xs)"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b")) `TypArr`
      (TypVar "c" `TypArr` (typVarList "a" `TypArr` TypVar "b")))
  testInferDef "Conslit binding 1" "list (x:xs:xss) = x" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 2" "list (x:xs:xss) = xs" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 3" "list (x:xs:xss) = xss" (typVarList "a" `TypArr` typVarList "a")
  testInferDef "Binding tuple 1" "fst (a, b) = a"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "a")
  testInferDef "Binding tuple 2" "snd (a, b) = b"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "b")
  testInferDef "Binding tuple 3" "f (a, b, c) = a b c"
    ((AD $ TTuple
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c") : TypVar "a" : TypVar "b" : Nil))
        `TypArr` TypVar "c")

  -- TODO:
  --testInferDefFail "Listlit binding" "list [a, b, c] = a b c" intType
    --(InfiniteType "a" (TypVar "a" `TypArr` TypVar "b"))

  -- +----------------------------------------------+
  -- | Test the inferred types of definition groups |
  -- +----------------------------------------------+

  let zipWithDef = "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
                   "zipWith _ [] _ = []\n" <>
                   "zipWith _ _ [] = []"
  testInferDefGroup "zipWith" zipWithDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c")) `TypArr`
      (typVarList "a" `TypArr` (typVarList "b" `TypArr` typVarList "c")))

  let foldrDef = "foldr f ini [] = ini\n" <>
                 "foldr f ini (x:xs) = f x (foldr f ini xs)"
  testInferDefGroup "foldr" foldrDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b"))
      `TypArr` (TypVar "b" `TypArr` (typVarList "a" `TypArr` TypVar "b")))

  let scanlDef = "scanl f b []     = [b]\n" <>
                 "scanl f b (x:xs) = b : scanl f (f b x) xs"
  testInferDefGroup "scanl" scanlDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "a"))
      `TypArr` (TypVar "a" `TypArr` (typVarList "b" `TypArr` typVarList "a")))

  -- +-------------------------------------------------------------------+
  -- | Test the inferred types of expressions in the prelude environment |
  -- +-------------------------------------------------------------------+

  testInferExprWithPrelude "Prelude with exp" "sum (map (^2) [1, 2, 3, 4])" intType

  -- +----------------------------------------+
  -- | Test the type inference on whole trees |
  -- +----------------------------------------+

  -- Check that \f x -> f x and all the subexpressions are typed correctly.
  testInferTT "Apply function"
    (Lambda Nothing
      ((Lit Nothing (Name "f")) : (Lit Nothing (Name "x")) : Nil)
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

  -- Check that [1, 1 + 1, length [1]] and all the subexpressions are typed correctly.
  testInferTT "List"
    (List
      Nothing
      (
        (Atom Nothing (AInt 1)) :
        (Binary
          Nothing
          (Tuple Add Nothing)
          (Atom Nothing (AInt 1))
          (Atom Nothing (AInt 1))) :
        (App
          Nothing
          (Atom
            Nothing
            (Name "length"))
          (untypedListOne : Nil)) :
        Nil
      )
    )
    (List
      (Just (typConList "Int"))
      (
        (Atom (Just (TypCon "Int")) (AInt 1)) :
        (Binary
          (Just (TypCon "Int"))
          (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
          (Atom (Just (TypCon "Int")) (AInt 1))
          (Atom (Just (TypCon "Int")) (AInt 1))) :
        (App
          (Just (TypCon "Int"))
          (Atom
            (Just (typConList "Int" `TypArr` TypCon "Int"))
            (Name "length"))
          (listOne : Nil)) :
        Nil
      )
    )

  -- Check that (\(x:xs) -> x) [1] and all the subexpressions are typed correctly.
  testInferTT "ConsLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((ConsLit
          Nothing
          (Lit Nothing (Name "x"))
          (Lit Nothing (Name "xs"))) : Nil)
        (Atom Nothing (Name "x")))
      (untypedListOne : Nil))
    (App
      (Just $ TypCon "Int")
      (Lambda
        (Just $ typConList "Int" `TypArr` TypCon "Int")
        ((ConsLit
          (Just $ typConList "Int")
          (Lit (Just $ TypCon "Int") (Name "x"))
          (Lit (Just $ typConList "Int") (Name "xs"))) : Nil)
        (Atom (Just $ TypCon "Int") (Name "x")))
      (listOne : Nil))

  -- Check that let x = [1] in [x] :: [[Int]] and all the subexpressions are typed correctly.
  testInferTT "Let"
    (LetExpr
      Nothing
      (Tuple (Lit Nothing (Name "x")) untypedListOne : Nil)
      (List Nothing (Atom Nothing (Name "x") : Nil)))
    (LetExpr
      (Just $ AD $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ AD $ TList $ typConList "Int")
        (Atom (Just $ typConList "Int") (Name "x") : Nil)))

-- lit "a"
-- intLit "a"

  -- Check that (\(a,b) -> ('1',b,a)) (1,2) :: (Char, Int, Int) and all the subexpressions are
  -- typed correctly.
  testInferTT "Tuple and NTupleLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((NTupleLit Nothing (
            Lit Nothing (Name "a") :
            Lit Nothing (Name "b") :
            Nil)) :
          Nil)
        (NTuple Nothing (
          Atom Nothing (Char "1") :
          Atom Nothing (Name "b") :
          Atom Nothing (Name "a") :
          Nil)))
      (NTuple Nothing (
          Atom Nothing (AInt 1) :
          Atom Nothing (AInt 2) :
          Nil) :
        Nil))
    (App
      (Just $ charIntTupleType)
      (Lambda
        (Just $ intTupleType `TypArr` charIntTupleType)
        ((NTupleLit (Just intTupleType) (
            Lit (Just intType) (Name "a") :
            Lit (Just intType) (Name "b") :
            Nil)) :
          Nil)
        (NTuple (Just charIntTupleType) (
          Atom (Just charType) (Char "1") :
          Atom (Just intType) (Name "b") :
          Atom (Just intType) (Name "a") :
          Nil)))
      (NTuple (Just intTupleType) (
          Atom (Just intType) (AInt 1) :
          Atom (Just intType) (AInt 2) :
          Nil) :
        Nil))

  -- +-----------------------------+
  -- | Test the tree normalization |
  -- +-----------------------------+

  -- Check that x :: t_42 == x :: a.
  testNormalizeTT "Atom"
    (Atom (Just $ TypVar "t_42") (Name "x"))
    (Atom (Just $ TypVar "a") (Name "x"))

  -- Check that an untyped atom stays untyped.
  testNormalizeTT "Untyped atom"
    (Atom Nothing (Name "x"))
    (Atom Nothing (Name "x"))

  -- Check that (\x -> x) :: t_2 -> t_2 == (\x -> x) :: a -> a.
  testNormalizeTT "Identity function"
    (Lambda
      (Just $ typVarArrow "t_2" "t_2")
      ((Lit (Just $ TypVar "t_2") (Name "x")) : Nil)
      (Atom (Just $ TypVar "t_2") (Name "x")))
    (Lambda
      (Just $ typVarArrow "a" "a")
      ((Lit (Just $ TypVar "a") (Name "x")) : Nil)
      (Atom (Just $ TypVar "a") (Name "x")))

  -- Check that (\(x, y) -> x) :: (t_10, t_2) -> t_10
  --         == (\(x, y) -> x) :: (a, b) -> a
  testNormalizeTT "Normalization: Tuple binding in lambda"
    (Lambda
      (Just (typVarTuple ("t_10" : "t_2" : Nil) `TypArr` TypVar "t_10"))
      (
        (NTupleLit (Just (typVarTuple ("t_10" : "t_2" : Nil)))
          (
            (Lit (Just (TypVar "t_10")) (Name "x")) :
            (Lit (Just (TypVar "t_2")) (Name "y")) :
            Nil
          )
        ) : Nil
      )
      (Atom (Just (TypVar "t_10")) (Name "x"))
    )
    (Lambda
      (Just (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "a"))
      (
        (NTupleLit (Just (typVarTuple ("a" : "b" : Nil)))
          (
            (Lit (Just (TypVar "a")) (Name "x")) :
            (Lit (Just (TypVar "b")) (Name "y")) :
            Nil
          )
        ) : Nil
      )
      (Atom (Just (TypVar "a")) (Name "x"))
    )

  -- Check that (\(x:xs) [a,b] (u,v,w) -> x) :: [t_4] -> [t_2] -> (t_1, t_3, t_5) -> t_4
  --         == (\(x:xs) [a,b] (u,v,w) -> x) :: [a] -> [b] -> (c, d, e) -> a
  testNormalizeTT "Normalization: Tuple binding in lambda"
    (Lambda
      -- :: [t_4] -> [t_2] -> (t_1, t_3, t_5) -> t_4
      (Just
        (typVarList "t_4" `TypArr`
          (typVarList "t_2" `TypArr`
            (typVarTuple ("t_1" : "t_3" : "t_5" : Nil)) `TypArr`
              TypVar "t_4")))
      (
        -- (x:xs) [a,b] (u,v,w)
        (ConsLit (Just (typVarList "t_4"))
          (Lit (Just (TypVar "t_4")) (Name "x"))
          (Lit (Just (typVarList "t_4")) (Name "xs"))
        ) :
        (ListLit (Just (typVarList "t_2"))
          (
            (Lit (Just (TypVar "t_2")) (Name "a")) :
            (Lit (Just (TypVar "t_2")) (Name "b")) :
            Nil
          )
        ) :
        (NTupleLit (Just (typVarTuple ("t_1" : "t_3" : "t_5" : Nil)))
          (
            (Lit (Just (TypVar "t_1")) (Name "u")) :
            (Lit (Just (TypVar "t_3")) (Name "v")) :
            (Lit (Just (TypVar "t_5")) (Name "w")) :
            Nil
          )
        ) :
        Nil
      )
      (Atom (Just (TypVar "t_4")) (Name "x"))
    )
    (Lambda
      -- :: [a] -> [b] -> (c, d, e) -> a
      (Just
        (typVarList "a" `TypArr`
          (typVarList "b" `TypArr`
            (typVarTuple ("c" : "d" : "e" : Nil)) `TypArr`
              TypVar "a")))
      (
        -- (x:xs) [a,b] (u,v,w)
        (ConsLit (Just (typVarList "a"))
          (Lit (Just (TypVar "a")) (Name "x"))
          (Lit (Just (typVarList "a")) (Name "xs"))
        ) :
        (ListLit (Just (typVarList "b"))
          (
            (Lit (Just (TypVar "b")) (Name "a")) :
            (Lit (Just (TypVar "b")) (Name "b")) :
            Nil
          )
        ) :
        (NTupleLit (Just (typVarTuple ("c" : "d" : "e" : Nil)))
          (
            (Lit (Just (TypVar "c")) (Name "u")) :
            (Lit (Just (TypVar "d")) (Name "v")) :
            (Lit (Just (TypVar "e")) (Name "w")) :
            Nil
          )
        ) :
        Nil
      )
      (Atom (Just (TypVar "a")) (Name "x"))
    )

  -- Check that (\f x -> f x) :: (t_4 -> t_45) -> t_4 -> t_45
  --         == (\f x -> f x) :: (a -> b) -> a -> b
  testNormalizeTT "Apply function"
    (Lambda
      (Just (typVarArrow "t_4" "t_45" `TypArr` typVarArrow "t_4" "t_45"))
      (
        (Lit (Just (typVarArrow "t_4" "t_45")) (Name "f")) :
        (Lit (Just (TypVar  "t_4")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "t_45"))
        (Atom (Just (typVarArrow "t_4" "t_45")) (Name "f"))
        ((Atom (Just (TypVar  "t_4")) (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

module Test.TypeChecker where

import AST
import TypeChecker as TC
import TypeChecker (charType, emptyTypeEnv, intType, intToIntType)
import Parser (parseExpr, parseDefs)
import Test.Parser (parsedPrelude)

import Prelude (Unit, bind, map, pure, show, unit, ($), (==), (<<<), (<>), (>>=))
import Control.Monad.Writer (Writer, tell)
import Data.Array as Array
import Data.Either (Either(..))
import Data.List (List(..), (:), singleton)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Text.Parsing.Parser (ParseError, parseErrorMessage)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

-- | Construct a list of type [typCon] given the name of the type constants.
typConList :: String -> Type
typConList name = AD $ TList (TypCon name)

-- | Construct a tuple type given a list of type constant names.
typConNTuple:: List String -> Type
typConNTuple names = AD $ TTuple (map TypCon names)

-- | Construct a tuple type given a list of type variable names.
typVarTuple :: List TVar -> Type
typVarTuple tvs = AD $ TTuple (map TypVar tvs)

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = AD $ TList (TypVar tv)

-- | Generate an arrow type from two given type variable names.
typVarArrow :: TVar -> TVar -> Type
typVarArrow tv1 tv2 = TypVar tv1 `TypArr` TypVar tv2

-- | The type (Char, Int, Int)
charIntTupleType :: Type
charIntTupleType = typConNTuple ("Char" : "Int" : "Int" : Nil)

-- | The type (Int, Int)
intTupleType :: Type
intTupleType = typConNTuple ("Int" : "Int" : Nil)

-- | The type [Int]
intList :: Type
intList = AD $ TList $ TypCon "Int"

-- | Report a parse error.
reportParseError :: String -> ParseError -> Writer (List String) Unit
reportParseError testName parseError = tell' $ "Parse error for test case "
  <> testName <> ": "
  <> parseErrorMessage parseError
  <> "\nNote that this is not a failing test but rather an error in the test definition."

-- | Report a type error.
reportTypeError :: String -> TypeError -> Writer (List String) Unit
reportTypeError testName typeError = tell' $ "Type inference failed in test case `"
  <> testName <> "`:\n"
  <> "Encountered type error: "
  <> prettyPrintTypeError typeError

-- | Compare the given two types and report an error if they are not equal.
compareTypes :: String -> Type -> Type -> Writer (List String) Unit
compareTypes testName expected actual = if expected == actual
  then pure unit
  else tell' $ "Type inference failed in test case `" <> testName <> "`:\n" <>
               "Expected type: " <> prettyPrintType expected <> "\n" <>
               "Actual type: " <> prettyPrintType actual

-- | Try to infer the type of a given expression and compare the result with the expected type.
testInferExpr :: String -> String -> Type -> Writer (List String) Unit
testInferExpr name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType expression) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  where
  inferAndConvertToType expr = TC.inferTypeNew expr >>= TC.schemeToType

-- | Try to infer the type of a given expression and expect a type error to occur.
testInferExprFail :: String -> String -> TypeError -> Writer (List String) Unit
testInferExprFail name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType expression) of
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
    Left typeError -> if typeError == expected
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type error: " <> prettyPrintTypeError typeError <> "\n" <>
                   "Actual type error: " <> prettyPrintTypeError expected <> "\n"
  where
  inferAndConvertToType expr = TC.inferTypeNew expr >>= TC.schemeToType

testInferDef :: String -> String -> Type -> Writer (List String) Unit
testInferDef name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType def) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.inferDefinitionToScheme def >>= TC.schemeToType

testInferDefFail :: String -> String -> TypeError -> Writer (List String) Unit
testInferDefFail name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (def:_) -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType def) of
    Left typeError -> if typeError == expected
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type error: " <> prettyPrintTypeError typeError <> "\n" <>
                   "Actual type error: " <> prettyPrintTypeError expected <> "\n"
    Right t -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                       "Expected type error: " <> prettyPrintTypeError expected <> "\n" <>
                       "Found type: " <> prettyPrintType t <> "\n"
  _ -> tell' $ "Expected to parse definition in test case `" <> name <> "`\n" <>
               "\nNote that this is not a failing test but rather an error in the test definition."
  where
  inferAndConvertToType def = TC.inferDefinitionToScheme def >>= TC.schemeToType

testInferDefGroup :: String -> String -> Type -> Writer (List String) Unit
testInferDefGroup name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right definitions -> case TC.runInferNew emptyTypeEnv true (inferAndConvertToType definitions) of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t
  where
  inferAndConvertToType defs = TC.inferDefinitions defs >>= TC.schemeToType

-- | Infer the type of the given expression in the context of the prelude.
testInferExprWithPrelude :: String -> String -> Type -> Writer (List String) Unit
testInferExprWithPrelude name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> case TC.inferTypeInContext parsedPrelude expression of
    Left typeError -> reportTypeError name typeError
    Right t -> compareTypes name expected t

-- | Test type inference on expression trees, given an expression string as well as the expected
-- | resulting typed tree.
testInferTT' :: String -> String -> TypeTree -> Writer (List String) Unit
testInferTT' name unparsedTree expectedTypeTree = case parseExpr unparsedTree of
  Left parseError -> reportParseError name parseError
  Right expression -> testInferTT name expression expectedTypeTree

-- | Test type inference on expression trees. Here not only the expected type of the whole
-- | expression is checked, but also the type of every subexpression.
testInferTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testInferTT name untypedTree expectedTypedTree =
  case TC.inferTypeTreeInContext parsedPrelude untypedTree of
    Left typeError -> reportTypeError name typeError
    Right typedTree -> if expectedTypedTree == typedTree
      then pure unit
      else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                   "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                   "Actual type tree: " <> show typedTree <> "\n"

-- | Test type tree normalization.
testNormalizeTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testNormalizeTT name tt normalizedTT = if (TC.normalizeTypeTree tt) == normalizedTT
  then pure unit
  else tell' $ "Type tree normalization failed in test case `" <> name <> "`:\n" <>
               "Expected type tree: " <> show normalizedTT <> "\n" <>
               "Actual type tree: " <> show tt <> "\n"

-- | Typed type tree representing `[1]`.
listOne :: TypeTree
listOne = List (Just $ typConList "Int") (Atom (Just $ TypCon "Int") (AInt 1) : Nil)

-- | Untyped type tree representing `[1]`.
untypedListOne :: TypeTree
untypedListOne = List Nothing (Atom Nothing (AInt 1) : Nil)

runTests :: Writer (List String) Unit
runTests = do

  -- +--------------------------------------------------+
  -- | Test the inferred types of arbitrary expressions |
  -- +--------------------------------------------------+

  -- (3^) :: Int -> Int
  testInferExpr "SectL" "(3^)" TC.intToIntType
  -- (^3) :: Int -> Int
  testInferExpr "SectR" "(^3)" TC.intToIntType
  -- (\a b c d -> a b c d) :: (a -> b -> c -> d) -> a -> b -> c -> d
  testInferExpr "Lambda1" "\\a b c d -> a b c d"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` TypVar "d"))) `TypArr`
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` (TypVar "c" `TypArr` (TypVar "d")))))
  testInferExpr "Lambda2" "\\a b -> a b"
    (TypArr (TypArr (TypVar "a") (TypVar "b")) (TypArr (TypVar "a") (TypVar "b")))
  testInferExpr "List1" "[1, 2, 3, 4, 5]" intList
  testInferExpr "List2" "[1 + 2, 3 + 4]" intList
  testInferExpr "Empty list" "[]" (typVarList "a")
  testInferExpr "Append" "[1 + 2, 3 + 4] ++ []" intList
  testInferExpr "NTuple" "(1 + 2, 3)" (typConNTuple ("Int" : "Int" : Nil))
  testInferExpr "SectR colon" "(:[3])" (TypCon "Int" `TypArr` intList)
  testInferExpr "Lambda wildcard" "\\_ _ -> 5" (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Lambda cons binding" "\\(x:xs) -> x" (typVarList "a" `TypArr` TypVar "a")
  testInferExpr "Let expression" "let x = 3 in \\_ _ -> x"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` intType))
  testInferExpr "Binding tuple in let expression" "let (a, b) = (\\f -> f, \"Hello\") in a b"
    (typConList "Char")
  testInferExpr "Lambda application" "(\\f a b -> f a b) (+) 3 4" intType
  -- ((\xs -> [ x | x <- xs ]) [1]) :: [Int]
  testInferExpr "List comprehension inside lambda" "(\\xs -> [ x | x <- xs ]) [1]" intList

  -- TODO:
  -- testInferExprFail "List3" "[(+), 4]" (UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))
  -- testInferExprFail "Colon" "3 : [1 + 2, 3 + 4, \"Hallo\"]" (Left ((UnificationFail (AD $ TList $ TypCon "Char") (TypCon "Int"))))

  -- +-----------------------------------------------+
  -- | Test the inferred types of single definitions |
  -- +-----------------------------------------------+

  testInferDef "Define app" "app f xs = app f xs"
    (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c"))
  testInferDef "Define single map" "map f (x:xs) = f x : map f xs"
    ((TypVar "a" `TypArr` TypVar "b") `TypArr` (typVarList "a" `TypArr` typVarList "b"))
  testInferDef "Define foldr" "foldr f ini (x:xs) = f x (foldr f ini xs)"
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b")) `TypArr`
      (TypVar "c" `TypArr` (typVarList "a" `TypArr` TypVar "b")))
  testInferDef "Conslit binding 1" "list (x:xs:xss) = x" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 2" "list (x:xs:xss) = xs" (typVarList "a" `TypArr` TypVar "a")
  testInferDef "Conslit binding 3" "list (x:xs:xss) = xss" (typVarList "a" `TypArr` typVarList "a")
  testInferDef "Binding tuple 1" "fst (a, b) = a"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "a")
  testInferDef "Binding tuple 2" "snd (a, b) = b"
    (typVarTuple ("a" : "b" : Nil) `TypArr` TypVar "b")
  testInferDef "Binding tuple 3" "f (a, b, c) = a b c"
    ((AD $ TTuple
      (TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c") : TypVar "a" : TypVar "b" : Nil))
        `TypArr` TypVar "c")

  -- TODO:
  --testInferDefFail "Listlit binding" "list [a, b, c] = a b c" intType
    --(InfiniteType "a" (TypVar "a" `TypArr` TypVar "b"))

  -- +----------------------------------------------+
  -- | Test the inferred types of definition groups |
  -- +----------------------------------------------+

  let zipWithDef = "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
                   "zipWith _ [] _ = []\n" <>
                   "zipWith _ _ [] = []"
  testInferDefGroup "zipWith" zipWithDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "c")) `TypArr`
      (typVarList "a" `TypArr` (typVarList "b" `TypArr` typVarList "c")))

  let foldrDef = "foldr f ini [] = ini\n" <>
                 "foldr f ini (x:xs) = f x (foldr f ini xs)"
  testInferDefGroup "foldr" foldrDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "b"))
      `TypArr` (TypVar "b" `TypArr` (typVarList "a" `TypArr` TypVar "b")))

  let scanlDef = "scanl f b []     = [b]\n" <>
                 "scanl f b (x:xs) = b : scanl f (f b x) xs"
  testInferDefGroup "scanl" scanlDef
    ((TypVar "a" `TypArr` (TypVar "b" `TypArr` TypVar "a"))
      `TypArr` (TypVar "a" `TypArr` (typVarList "b" `TypArr` typVarList "a")))

  -- +-------------------------------------------------------------------+
  -- | Test the inferred types of expressions in the prelude environment |
  -- +-------------------------------------------------------------------+

  testInferExprWithPrelude "Prelude with exp" "sum (map (^2) [1, 2, 3, 4])" intType

  -- +----------------------------------------+
  -- | Test the type inference on whole trees |
  -- +----------------------------------------+

  -- Check that \f x -> f x and all the subexpressions are typed correctly.
  testInferTT "Apply function"
    (Lambda Nothing
      ((Lit Nothing (Name "f")) : (Lit Nothing (Name "x")) : Nil)
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

  -- Check that [1, 1 + 1, length [1]] and all the subexpressions are typed correctly.
  testInferTT "List"
    (List
      Nothing
      (
        (Atom Nothing (AInt 1)) :
        (Binary
          Nothing
          (Tuple Add Nothing)
          (Atom Nothing (AInt 1))
          (Atom Nothing (AInt 1))) :
        (App
          Nothing
          (Atom
            Nothing
            (Name "length"))
          (untypedListOne : Nil)) :
        Nil
      )
    )
    (List
      (Just (typConList "Int"))
      (
        (Atom (Just (TypCon "Int")) (AInt 1)) :
        (Binary
          (Just (TypCon "Int"))
          (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
          (Atom (Just (TypCon "Int")) (AInt 1))
          (Atom (Just (TypCon "Int")) (AInt 1))) :
        (App
          (Just (TypCon "Int"))
          (Atom
            (Just (typConList "Int" `TypArr` TypCon "Int"))
            (Name "length"))
          (listOne : Nil)) :
        Nil
      )
    )

  -- Check that (\(x:xs) -> x) [1] and all the subexpressions are typed correctly.
  testInferTT "ConsLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((ConsLit
          Nothing
          (Lit Nothing (Name "x"))
          (Lit Nothing (Name "xs"))) : Nil)
        (Atom Nothing (Name "x")))
      (untypedListOne : Nil))
    (App
      (Just $ TypCon "Int")
      (Lambda
        (Just $ typConList "Int" `TypArr` TypCon "Int")
        ((ConsLit
          (Just $ typConList "Int")
          (Lit (Just $ TypCon "Int") (Name "x"))
          (Lit (Just $ typConList "Int") (Name "xs"))) : Nil)
        (Atom (Just $ TypCon "Int") (Name "x")))
      (listOne : Nil))

  -- Check that let x = [1] in [x] :: [[Int]] and all the subexpressions are typed correctly.
  testInferTT "Let"
    (LetExpr
      Nothing
      (Tuple (Lit Nothing (Name "x")) untypedListOne : Nil)
      (List Nothing (Atom Nothing (Name "x") : Nil)))
    (LetExpr
      (Just $ AD $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ AD $ TList $ typConList "Int")
        (Atom (Just $ typConList "Int") (Name "x") : Nil)))

-- lit "a"
-- intLit "a"

  -- Check that (\(a,b) -> ('1',b,a)) (1,2) :: (Char, Int, Int) and all the subexpressions are
  -- typed correctly.
  testInferTT "Tuple and NTupleLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((NTupleLit Nothing (
            Lit Nothing (Name "a") :
            Lit Nothing (Name "b") :
            Nil)) :
          Nil)
        (NTuple Nothing (
          Atom Nothing (Char "1") :
          Atom Nothing (Name "b") :
          Atom Nothing (Name "a") :
          Nil)))
      (NTuple Nothing (
          Atom Nothing (AInt 1) :
          Atom Nothing (AInt 2) :
          Nil) :
        Nil))
    (App
      (Just $ charIntTupleType)
      (Lambda
        (Just $ intTupleType `TypArr` charIntTupleType)
        ((NTupleLit (Just intTupleType) (
            Lit (Just intType) (Name "a") :
            Lit (Just intType) (Name "b") :
            Nil)) :
          Nil)
        (NTuple (Just charIntTupleType) (
          Atom (Just charType) (Char "1") :
          Atom (Just intType) (Name "b") :
          Atom (Just intType) (Name "a") :
          Nil)))
      (NTuple (Just intTupleType) (
          Atom (Just intType) (AInt 1) :
          Atom (Just intType) (AInt 2) :
          Nil) :
        Nil))

  -- +-----------------------------+
  -- | Test the tree normalization |
  -- +-----------------------------+

  -- Check that x :: t_42 == x :: a.
  testNormalizeTT "Atom"
    (Atom (Just $ TypVar "t_42") (Name "x"))
    (Atom (Just $ TypVar "a") (Name "x"))

  -- Check that an untyped atom stays untyped.
  testNormalizeTT "Untyped atom"
    (Atom Nothing (Name "x"))
    (Atom Nothing (Name "x"))

  -- Check that (\x -> x) :: t_2 -> t_2 == (\x -> x) :: a -> a.
  testNormalizeTT "Identity function"
    (Lambda
      (Just $ typVarArrow "t_2" "t_2")
      ((Lit (Just $ TypVar "t_2") (Name "x")) : Nil)
      (Atom (Just $ TypVar "t_2") (Name "x")))
    (Lambda
      (Just $ typVarArrow "a" "a")
      ((Lit (Just $ TypVar "a") (Name "x")) : Nil)
      (Atom (Just $ TypVar "a") (Name "x")))

  -- Check that (\f x -> f x) :: (t_4 -> t_45) -> t_4 -> t_45
  --         == (\f x -> f x) :: (a -> b) -> a -> b
  testNormalizeTT "Apply function"
    (Lambda
      (Just (typVarArrow "t_4" "t_45" `TypArr` typVarArrow "t_4" "t_45"))
      (
        (Lit (Just (typVarArrow "t_4" "t_45")) (Name "f")) :
        (Lit (Just (TypVar  "t_4")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "t_45"))
        (Atom (Just (typVarArrow "t_4" "t_45")) (Name "f"))
        ((Atom (Just (TypVar  "t_4")) (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))