Add test case (infer type of `(\xs -> [x | x <- xs]) [1]`)

module Test.TypeChecker where

import AST (AD(TList, TTuple), Atom(AInt, Name, Char), Binding(Lit, ConsLit, ListLit, NTupleLit), Definition(Def), Expr(Atom, List, SectR, App, Binary, PrefixOp, Lambda, NTuple, LetExpr, SectL, ListComp), Op(Power, Colon, Add, Append), TVar, Type(TypCon, TypVar, AD, TypArr), TypeError(InfiniteType, UnificationFail, UnknownError), Qual(..), prettyPrintType)
import TypeChecker (Subst, Infer, TypeEnv, Scheme(Forall), inferGroup, inferType, inferDef, emptyTyenv, runInfer, typeProgramn, eqScheme)
import Parser (expression, definition, runParserIndent)

import Prelude (Unit, bind, ($), show, (==), (<>))
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.Array (toUnfoldable) as Array
import Data.Tuple (Tuple(..))
import Test.Parser (parsedPrelude)

import Text.Parsing.Parser (ParseError)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

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

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  <> name <> ")"
  else log $ "\n \n Typing fail (" <> name <> ") :  expected result: \n"
    <> show expected <> "\n actuall result: \n" <> show actuall <> "\n \n"
     <> "Pretty Print expected: \n" <> prettyPrint expected
      <> "\n Pretty Print actuall: \n" <> prettyPrint actuall <> "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar = TypVar

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp = runParserIndent expression

parseDef:: String -> Either ParseError Definition
parseDef = runParserIndent definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParserIndent expression expS of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParserIndent expression expS of
  Right exp -> typeProgramn parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 :: Either TypeError Scheme
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList ["b", "c", "d", "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall ("t_3" : "t_4" : Nil) (TypArr (TypArr (TypVar "t_3") (TypVar "t_4")) (TypArr (TypVar "t_3") (TypVar "t_4")))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType (Right (Forall ("t_0" : Nil) (AD (TList (TypVar "t_0")))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall ("t_2" : "t_4" : "t_5" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypVar "t_5")))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType (Right (Forall ("t_1" : "t_3" : Nil) (TypArr (TypVar "t_1") (TypArr (TypVar "t_3") (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall ("t_11" : "t_5" : Nil) (TypArr (TypArr (TypVar "t_5") (TypVar "t_11")) (TypArr (AD (TList (TypVar "t_5"))) (AD (TList (TypVar "t_11")))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall ("t_5" : "t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_5") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))
  testInfer "let Expr" (LetExpr (Cons (Tuple (Lit $ Name "x") (aint 3)) Nil) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType (Right (Forall ("t_2" : "t_4" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (AD (TList (TypVar "t_2"))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple $ Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil)))) (TypVar "t_2"))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple (Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil))))) (TypVar "t_3"))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall ("t_3" : "t_4" : "t_5" : Nil) (TypArr (AD (TTuple (Cons ((TypArr (TypVar "t_3") (TypArr (TypVar "t_4") (TypVar "t_5")))) (Cons ((TypVar "t_3")) (Cons ((TypVar "t_4")) (Nil)))))) (TypVar "t_5"))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType "a" (TypArr (TypVar "a") (TypVar "b")))))
  testInfer "NTupleLit Binding LetExp" (LetExpr (Cons (Tuple (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")]))) Nil) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))
  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
      inferGroup (Right (Forall ("t_23" : "t_33" : "t_34" : Nil) (TypArr (TypArr (TypVar "t_23") (TypArr (TypVar "t_33") (TypVar "t_34"))) (TypArr (AD (TList (TypVar "t_23"))) (TypArr (AD (TList (TypVar "t_33"))) (AD (TList (TypVar "t_34"))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
      inferGroup ((Right (Forall ("t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_4") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4")))))))

  testInfer "scanl - Group" (toList [Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil))),
                                     Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))])
   inferGroup (Right (Forall ("t_39" : "t_48" : Nil) (TypArr (TypArr (TypVar "t_48") (TypArr (TypVar "t_39") (TypVar "t_48"))) (TypArr (TypVar "t_48") (TypArr (AD (TList (TypVar "t_39"))) (AD (TList (TypVar "t_48"))))))))

  testProgramm "Prelude with exp" parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))

  -- ((\xs -> [ x | x <- xs ]) [1]) :: [Int]
  testInfer "List comprehension inside Lambda"
    (App (Lambda ((Lit $ Name "xs") : Nil) (ListComp (Atom $ Name "x") ((Gen (Lit $ Name "x") (Atom $ Name "xs")) : Nil))) ((List $ ((Atom $ AInt 1) : Nil)) : Nil))
    inferType
    (Right (Forall (Nil) (AD $ TList $ TypCon "Int")))

module Test.TypeChecker where

import AST (AD(TList, TTuple), Atom(AInt, Name, Char), Binding(Lit, ConsLit, ListLit, NTupleLit), Definition(Def), Expr(Atom, List, SectR, App, Binary, PrefixOp, Lambda, NTuple, LetExpr, SectL), Op(Power, Colon, Add, Append), TVar, Type(TypCon, TypVar, AD, TypArr), TypeError(InfiniteType, UnificationFail, UnknownError), prettyPrintType)
import TypeChecker (Subst, Infer, TypeEnv, Scheme(Forall), inferGroup, inferType, inferDef, emptyTyenv, runInfer, typeProgramn, eqScheme)
import Parser (expression, definition, runParserIndent)

import Prelude (Unit, bind, ($), show, (==), (<>))
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.Array (toUnfoldable) as Array
import Data.Tuple (Tuple(..))
import Test.Parser (parsedPrelude)

import Text.Parsing.Parser (ParseError)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

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

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  <> name <> ")"
  else log $ "\n \n Typing fail (" <> name <> ") :  expected result: \n"
    <> show expected <> "\n actuall result: \n" <> show actuall <> "\n \n"
     <> "Pretty Print expected: \n" <> prettyPrint expected
      <> "\n Pretty Print actuall: \n" <> prettyPrint actuall <> "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar = TypVar

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp = runParserIndent expression

parseDef:: String -> Either ParseError Definition
parseDef = runParserIndent definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParserIndent expression expS of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParserIndent expression expS of
  Right exp -> typeProgramn parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 :: Either TypeError Scheme
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList ["b", "c", "d", "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall ("t_3" : "t_4" : Nil) (TypArr (TypArr (TypVar "t_3") (TypVar "t_4")) (TypArr (TypVar "t_3") (TypVar "t_4")))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType (Right (Forall ("t_0" : Nil) (AD (TList (TypVar "t_0")))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall ("t_2" : "t_4" : "t_5" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypVar "t_5")))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType (Right (Forall ("t_1" : "t_3" : Nil) (TypArr (TypVar "t_1") (TypArr (TypVar "t_3") (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall ("t_11" : "t_5" : Nil) (TypArr (TypArr (TypVar "t_5") (TypVar "t_11")) (TypArr (AD (TList (TypVar "t_5"))) (AD (TList (TypVar "t_11")))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall ("t_5" : "t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_5") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))
  testInfer "let Expr" (LetExpr (Cons (Tuple (Lit $ Name "x") (aint 3)) Nil) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType (Right (Forall ("t_2" : "t_4" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (AD (TList (TypVar "t_2"))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple $ Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil)))) (TypVar "t_2"))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple (Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil))))) (TypVar "t_3"))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall ("t_3" : "t_4" : "t_5" : Nil) (TypArr (AD (TTuple (Cons ((TypArr (TypVar "t_3") (TypArr (TypVar "t_4") (TypVar "t_5")))) (Cons ((TypVar "t_3")) (Cons ((TypVar "t_4")) (Nil)))))) (TypVar "t_5"))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType "a" (TypArr (TypVar "a") (TypVar "b")))))
  testInfer "NTupleLit Binding LetExp" (LetExpr (Cons (Tuple (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")]))) Nil) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))
  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
      inferGroup (Right (Forall ("t_23" : "t_33" : "t_34" : Nil) (TypArr (TypArr (TypVar "t_23") (TypArr (TypVar "t_33") (TypVar "t_34"))) (TypArr (AD (TList (TypVar "t_23"))) (TypArr (AD (TList (TypVar "t_33"))) (AD (TList (TypVar "t_34"))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
      inferGroup ((Right (Forall ("t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_4") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4")))))))

  testInfer "scanl - Group" (toList [Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil))),
                                     Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))])
   inferGroup (Right (Forall ("t_39" : "t_48" : Nil) (TypArr (TypArr (TypVar "t_48") (TypArr (TypVar "t_39") (TypVar "t_48"))) (TypArr (TypVar "t_48") (TypArr (AD (TList (TypVar "t_39"))) (AD (TList (TypVar "t_48"))))))))

  testProgramm "Prelude with exp" parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))


Add test/example how to configure Root path in different manner

module Test.Main where

import Prelude

import Control.Error.Util (hush)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Timer (TIMER)
import Data.Generic (gShow, class Generic, gEq)
import Data.Generic.Rep as Generic.Rep
import Data.List (List(Nil), (:))
import Data.Maybe (Maybe(..), isJust)
import Data.StrMap (StrMap, empty)
import Data.String (Pattern(..), dropWhile, lastIndexOf)
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(Tuple))
import Data.URI (Query(Query))
import Data.URI.Query as Query
import Routing.Bob (Router(..), defaultOptions, fromUrl, genericFromUrl', genericToUrl', router, router', toUrl)
import Routing.Bob.UrlBoomerang (UrlBoomerang, liftStringBoomerang)
import Test.Unit (suite, failure, test)
import Test.Unit.Assert (equal)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Text.Boomerang.Generic (constructorBoomerang)
import Text.Boomerang.HStack (HCons, type (:-))
import Text.Boomerang.String (lit, manyNoneOf)
import Text.Parsing.StringParser (runParser)
import Type.Proxy (Proxy(..))

data BooleanIntRoute = BooleanIntRoute
  { extended :: Boolean
  , id :: Int
  }
derive instance genericBooleanIntRoute :: Generic BooleanIntRoute

data PrimitivePositionalValue = PrimitivePositionalValue Int
derive instance genericPrimitivePositionalValue :: Generic PrimitivePositionalValue
instance eqPrimitivePositionalValue :: Eq PrimitivePositionalValue where
  eq = gEq
instance showPrimitivePositionalValue :: Show PrimitivePositionalValue where
  show = gShow

data PrimitivePositionalValues = PrimitivePositionalValues Int Boolean Int
derive instance genericPrimitivePositionalValues :: Generic PrimitivePositionalValues
instance eqPrimitivePositionalValues :: Eq PrimitivePositionalValues where
  eq = gEq
instance showPrimitivePositionalValues :: Show PrimitivePositionalValues where
  show = gShow

data UnionOfEmptyConstructors = FirstEmptyConstructor | SecondEmptyConstructor
derive instance genericUnionOfEmptyConstructors :: Generic UnionOfEmptyConstructors
instance eqUnionOfEmptyConstructors :: Eq UnionOfEmptyConstructors where
  eq = gEq
instance showUnionOfEmptyConstructors :: Show UnionOfEmptyConstructors where
  show = gShow

data UnionOfPrimitivePositionalValues =
    FirstConstructor Int Boolean Int
  | SecondConstructor Boolean
derive instance genericUnionOfPrimitivePositionalValues :: Generic UnionOfPrimitivePositionalValues
instance eqUnionOfPrimitivePositionalValues :: Eq UnionOfPrimitivePositionalValues where
  eq = gEq
instance showUnionOfPrimitivePositionalValues :: Show UnionOfPrimitivePositionalValues where
  show = gShow
derive instance genericRepUnionOfPrimitivePositionalValues ∷ Generic.Rep.Generic UnionOfPrimitivePositionalValues _

data NestedStructureWithPrimitivePositionvalValue =
  NestedStructureWithPrimitivePositionvalValue PrimitivePositionalValue
derive instance genericNestedStructureWithPrimitivePositionvalValue :: Generic NestedStructureWithPrimitivePositionvalValue
instance eqNestedStructureWithPrimitivePositionvalValue :: Eq NestedStructureWithPrimitivePositionvalValue where
  eq = gEq
instance showNestedStructureWithPrimitivePositionvalValue :: Show NestedStructureWithPrimitivePositionvalValue where
  show = gShow

data NestedStructures =
    FirstOuterConstructor UnionOfPrimitivePositionalValues
  | SecondOuterConstructor PrimitivePositionalValues
derive instance genericNestedStructures :: Generic NestedStructures
instance eqNestedStructures :: Eq NestedStructures where
  eq = gEq
instance showNestedStructures:: Show NestedStructures where
  show = gShow

data StringValue = StringValue String
derive instance genericStringValue :: Generic StringValue
instance eqStringValue :: Eq StringValue where
  eq = gEq
instance showStringValue:: Show StringValue where
  show = gShow

data SumWithInternalRecords
  = FirstConstructorWithRecord
      Int
      { int1 :: Maybe Int
      , string1 :: String
      }
  | SecondConstructorWithRecord
      String
      { int2 :: Maybe Int
      , string2 :: String
      , boolean2 :: Boolean
      }
derive instance genericSumWithInternalRecords :: Generic SumWithInternalRecords

newtype Params =
  Params
    { paramString :: String
    , paramInt :: Int
    , paramBoolean :: Boolean
    }
derive instance genericParms :: Generic Params
derive instance eqParams :: Eq Params
instance showParams :: Show Params where
  show = gShow

params :: String -> Int -> Boolean -> Params
params = ((Params <$> _) <$>  _) <$> {paramString: _, paramInt: _, paramBoolean: _ }

newtype ParamsWithMaybes =
  ParamsWithMaybes
    { optParamString :: Maybe String
    , optParamInt :: Maybe Int
    , optParamBoolean :: Maybe Boolean
    }
derive instance genericParamsWithMaybes :: Generic ParamsWithMaybes
derive instance eqParamsWithMaybes :: Eq ParamsWithMaybes
instance showParamsWithMaybes :: Show ParamsWithMaybes where
  show = gShow

data Optional a = Value a | Missing
derive instance genericOptional :: Generic a => Generic (Optional a)
derive instance eqOptional :: Eq a => Eq (Optional a)
instance showOptional :: Generic a => Show (Optional a) where
  show = gShow

newtype ParamsWithOptionals =
  ParamsWithOptionals
    { optParamString :: Optional String
    , optParamInt :: Optional Int
    , optParamBoolean :: Optional Boolean
    }
derive instance genericParamsWithOptionals :: Generic ParamsWithOptionals
derive instance eqParamsWithOptionals :: Eq ParamsWithOptionals
instance showParamsWithOptionals :: Show ParamsWithOptionals where
  show = gShow

newtype RecordWithArrays =
  RecordWithArrays
    { arrayOfStrings :: Array String
    , arrayOfInts :: Array Int
    , arrayOfBooleans :: Array Boolean
    }
derive instance genericRecordWithArrays :: Generic RecordWithArrays
derive instance eqRecordWithArrays :: Eq RecordWithArrays
instance showRecordWithArrays :: Show RecordWithArrays where
  show = gShow

any :: forall r. UrlBoomerang r (HCons String r)
any = liftStringBoomerang $ manyNoneOf ""

-- regression tests

data MainWindowRoute = Profile | Inbox | Settings
derive instance genericMainWindowRoute :: Generic MainWindowRoute
data SideBarRoute = Expanded | Minimized
derive instance genericSideBarRoute :: Generic SideBarRoute
data AppRoute = AppRoute MainWindowRoute SideBarRoute
derive instance genericAppRoute :: Generic AppRoute

-- Urls with integrated root path
data UrlsWithRoot = Root | Page1 String | Page2 Int
derive instance genericUrlsWithRoot ∷ Generic UrlsWithRoot
instance eqUrlsWithRoot :: Eq UrlsWithRoot where
  eq = gEq
instance showUrlsWithRoot :: Show UrlsWithRoot where
  show = gShow

-- Another strategy to handle root path
data WithRoot r = WRoot | WSub r
derive instance genericRepWithRoot ∷ Generic.Rep.Generic (WithRoot a) _
derive instance genericWithRoot ∷ (Generic a) ⇒ Generic (WithRoot a)
instance eqWithRoot :: (Generic (WithRoot a)) ⇒ Eq (WithRoot a) where
  eq = gEq
instance showWithRoot :: (Generic (WithRoot a)) ⇒ Show (WithRoot a) where
  show = gShow

subrouteR :: forall a r
  . UrlBoomerang r (a :- r)
  → UrlBoomerang r (WithRoot a :- r)
subrouteR r = constructorBoomerang (SProxy :: SProxy "WSub") <<< r
rootR :: forall a r. UrlBoomerang r (WithRoot a :- r)
rootR = constructorBoomerang (SProxy :: SProxy "WRoot") <<< liftStringBoomerang (lit "")

addRoot :: forall a r t
  . (Generic.Rep.Generic a t)
  ⇒ Router a
  -> Router (WithRoot a)
addRoot (Router r) =
  Router (subrouteR r <> rootR)

isSuffixOf :: Pattern -> String -> Boolean
isSuffixOf suffix = isJust <<< lastIndexOf suffix

main :: forall e. Eff ( timer :: TIMER
                      , avar :: AVAR
                      , console :: CONSOLE
                      , testOutput :: TESTOUTPUT | e
                      ) Unit
main = runTest $ suite "Routing.Bob handles" do
  let
    path s = { path: s, query: empty :: StrMap (Maybe String) }
    query q = { path: "", query: q }
  let
    withRouter :: forall a e'. (Generic a) =>
      Proxy a ->
      (Router a -> Aff (timer :: TIMER , avar :: AVAR , testOutput :: TESTOUTPUT | e') Unit) ->
      Aff (timer :: TIMER , avar :: AVAR , testOutput :: TESTOUTPUT | e') Unit
    withRouter p t = (case router' p of
      Nothing -> failure ("Router generation failed")
      (Just b)-> t b)

  suite "url path" do
    test "which contains constructor with single, primitive value" do
      let obj = PrimitivePositionalValue 8
      withRouter (Proxy :: Proxy PrimitivePositionalValue) (\r -> do
        equal "8" (toUrl r obj)
        equal (Just obj) (fromUrl r "8")
        equal (Just obj) (fromUrl r "8?"))
    test "and consumes whole input" do
      let obj = PrimitivePositionalValue 8
      withRouter (Proxy :: Proxy PrimitivePositionalValue) (\r -> do
        equal (Nothing) (fromUrl r "8/something-more"))

    test "which contains construtor with multiple, primitive values" do
      let obj = PrimitivePositionalValues 8 true 9
      withRouter (Proxy :: Proxy PrimitivePositionalValues) (\r -> do
        equal "8/on/9" (toUrl r obj)
        equal (Just obj) (fromUrl r "8/on/9"))

    test "which contains multiple empty constructors" do
       let fObj = FirstEmptyConstructor
           sObj = SecondEmptyConstructor
       withRouter (Proxy :: Proxy UnionOfEmptyConstructors) (\r -> do
         equal "first-empty-constructor" (toUrl r fObj)
         equal "second-empty-constructor" (toUrl r sObj)

         equal (Just fObj) (fromUrl r "first-empty-constructor")
         equal (Just sObj) (fromUrl r "second-empty-constructor"))

    test "which contains multiple non empty constructors" do
      let fObj = FirstConstructor 8 true 9
          sObj = SecondConstructor false
      withRouter (Proxy :: Proxy UnionOfPrimitivePositionalValues) (\r -> do
        equal "first-constructor/8/on/9" (toUrl r fObj)
        equal "second-constructor/off" (toUrl r sObj)

        equal (Just fObj) (fromUrl r "first-constructor/8/on/9")
        equal (Just sObj) (fromUrl r "second-constructor/off"))

    test "root path encoding" do
      let rObj = Root
          serializeConstructorName s | (Pattern ".Root") `isSuffixOf` s = ""
          serializeConstructorName s = defaultOptions.serializeConstructorName s
      case router ({ serializeConstructorName: serializeConstructorName }) (Proxy :: Proxy UrlsWithRoot) of
        Nothing -> failure ("Router generation failed")
        Just r -> do
          equal "" (toUrl r Root)
          equal (Just Root) (fromUrl r "")

          equal "page1/param" (toUrl r (Page1 "param"))
          equal "page2/8" (toUrl r (Page2 8))
          equal (Just (Page1 "param")) (fromUrl r "page1/param")

    test "added root path encoding" do
      let
        fObj = WSub (FirstConstructor 8 true 9)
        sObj = WSub (SecondConstructor false)
        rObj = WRoot
      case router defaultOptions (Proxy :: Proxy UnionOfPrimitivePositionalValues) of
        Nothing -> failure ("Router generation failed")
        Just r -> do
          let r' = addRoot r
          equal "" (toUrl r' WRoot)
          equal (Just WRoot) (fromUrl r' "")

          equal "first-constructor/8/on/3" (toUrl r' (WSub (FirstConstructor 8 true 3)))
          equal "second-constructor/off" (toUrl r' (WSub (SecondConstructor false)))

    test "through generic helpers" do
        equal
          (Just "first-constructor/8/on/9")
          (genericToUrl' (FirstConstructor 8 true 9))
        equal
          (Just "second-constructor/off")
          (genericToUrl' (SecondConstructor false))

        equal (Just (FirstConstructor 8 true 9)) (genericFromUrl' "first-constructor/8/on/9")
        equal (Just (SecondConstructor false)) (genericFromUrl' "second-constructor/off")

    test "through generic helpers mixed with boomerang generic" do
        equal
          (Just "first-constructor/8/on/9")
          (genericToUrl' (FirstConstructor 8 true 9))
        equal
          (Just "second-constructor/off")
          (genericToUrl' (SecondConstructor false))

        equal (Just (FirstConstructor 8 true 9)) (genericFromUrl' "first-constructor/8/on/9")
        equal (Just (SecondConstructor false)) (genericFromUrl' "second-constructor/off")

    test "which contains nested structure with primitive values" do
      let obj = NestedStructureWithPrimitivePositionvalValue (PrimitivePositionalValue 8)
      withRouter (Proxy :: Proxy NestedStructureWithPrimitivePositionvalValue) (\r -> do
        equal "8" (toUrl r obj)
        equal (Just obj) (fromUrl r "8"))

    test "which contains nesteted structures with mutilple constructors" do
      let fObj = FirstOuterConstructor (FirstConstructor 100 true 888)
          sObj = SecondOuterConstructor (PrimitivePositionalValues 8 false 100)

      withRouter (Proxy :: Proxy NestedStructures) (\r -> do
        equal "first-outer-constructor/first-constructor/100/on/888" (toUrl r fObj)
        equal (Just fObj) (fromUrl r "first-outer-constructor/first-constructor/100/on/888")

        equal "second-outer-constructor/8/off/100" (toUrl r sObj)
        equal (Just sObj) (fromUrl r "second-outer-constructor/8/off/100"))

    test "which contains multiple nesteted structures with multiple constructors" do
      withRouter (Proxy :: Proxy AppRoute) (\r -> do
        equal "profile/minimized" (toUrl r (AppRoute Profile Minimized)))

    test "and uses correct escaping for string values" do
      let obj = StringValue "this is test%string"
      withRouter (Proxy :: Proxy StringValue) (\r -> do
        equal "this%20is%20test%25string" (toUrl r obj)
        equal (Just obj) (fromUrl r "this%20is%20test%25string"))
  suite "query with optional values" do
    let
      p = ParamsWithMaybes { optParamBoolean: Just false, optParamInt: Nothing, optParamString: Nothing }
    suite "parsing" do
      test "through generic helper from String" do
        equal
          (Just p)
          (genericFromUrl' "?optParamString&optParamBoolean=off")
    suite "serialization" do
      test "through generic helper from String" do
        equal
          (Just "?optParamBoolean=off")
          (genericToUrl' p)

  suite "query" do
    let
      q =  Tuple "paramString" (Just "test") :  Tuple "paramInt" (Just "8") : Tuple "paramBoolean" (Just "off") : Nil
      p = Params { paramBoolean: false, paramInt: 8, paramString: "test" }
    suite "serialization" do
      test "through generic helper" do
        equal
          (Just <<< Query $ q)
          (genericToUrl' p >>= (\q' -> hush <<< runParser Query.parser <<< dropWhile ('?' == _) $ q'))
      test "for constructor with records and maybe values" do
        let fObj = FirstConstructorWithRecord 8 { int1: Just 8, string1: "string1value" }
            sObj = SecondConstructorWithRecord "test" { int2: Nothing, string2: "string2value", boolean2: false }

        withRouter (Proxy :: Proxy SumWithInternalRecords) (\r -> do
          equal "first-constructor-with-record/8/?string1=string1value&int1=8" (toUrl r fObj)
          equal "second-constructor-with-record/test/?string2=string2value&boolean2=off" (toUrl r sObj))
      test "for constructor with records and values isomorphic to maybe" do
        let fObj = ParamsWithOptionals { optParamString: Value "test", optParamInt: Missing, optParamBoolean: Missing}
            sObj = ParamsWithOptionals { optParamString: Missing, optParamInt: Value 8, optParamBoolean: Missing}

        withRouter (Proxy :: Proxy ParamsWithOptionals) (\r -> do
          equal "?optParamString=test" (toUrl r fObj)
          equal (Just sObj) (fromUrl r "?optParamInt=8&optParamBoolean"))
    suite "parsing" do
      test "through generic helper from String" do
        equal
          (Just p)
          (genericFromUrl' "?paramString=test&paramInt=8&paramBoolean=off")

  suite "query with arrays" do
    let
      p = RecordWithArrays { arrayOfStrings: ["string1", "string2"], arrayOfInts: [1], arrayOfBooleans: [] }
    suite "parsing" do
      test "through generic helper from String" do
        equal
          (Just p)
          (genericFromUrl' "?arrayOfInts=1&arrayOfStrings=string1&arrayOfStrings=string2")
    suite "serialization" do
      test "through generic helper to String" do
        equal
          (Just "?arrayOfStrings=string1&arrayOfStrings=string2&arrayOfInts=1")
          (genericToUrl' p)

module Test.Main where

import Prelude

import Control.Error.Util (hush)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Timer (TIMER)
import Data.Generic (gShow, class Generic, gEq)
import Data.Generic.Rep as Generic.Rep
import Data.List (List(Nil), (:))
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap, empty)
import Data.String (dropWhile)
import Data.Tuple (Tuple(Tuple))
import Data.URI (Query(Query))
import Data.URI.Query as Query
import Routing.Bob (Router, defaultOptions, fromUrl, genericFromUrl', genericToUrl', router, router', toUrl)
import Routing.Bob.UrlBoomerang (UrlBoomerang, liftStringBoomerang)
import Test.Unit (suite, failure, test)
import Test.Unit.Assert (equal)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Text.Boomerang.HStack (HCons)
import Text.Boomerang.String (manyNoneOf)
import Text.Parsing.StringParser (runParser)
import Type.Proxy (Proxy(..))

data BooleanIntRoute = BooleanIntRoute
  { extended :: Boolean
  , id :: Int
  }
derive instance genericBooleanIntRoute :: Generic BooleanIntRoute

data PrimitivePositionalValue = PrimitivePositionalValue Int
derive instance genericPrimitivePositionalValue :: Generic PrimitivePositionalValue
instance eqPrimitivePositionalValue :: Eq PrimitivePositionalValue where
  eq = gEq
instance showPrimitivePositionalValue :: Show PrimitivePositionalValue where
  show = gShow

data PrimitivePositionalValues = PrimitivePositionalValues Int Boolean Int
derive instance genericPrimitivePositionalValues :: Generic PrimitivePositionalValues
instance eqPrimitivePositionalValues :: Eq PrimitivePositionalValues where
  eq = gEq
instance showPrimitivePositionalValues :: Show PrimitivePositionalValues where
  show = gShow

data UnionOfEmptyConstructors = FirstEmptyConstructor | SecondEmptyConstructor
derive instance genericUnionOfEmptyConstructors :: Generic UnionOfEmptyConstructors
instance eqUnionOfEmptyConstructors :: Eq UnionOfEmptyConstructors where
  eq = gEq
instance showUnionOfEmptyConstructors :: Show UnionOfEmptyConstructors where
  show = gShow

data UnionOfPrimitivePositionalValues =
    FirstConstructor Int Boolean Int
  | SecondConstructor Boolean
derive instance genericUnionOfPrimitivePositionalValues :: Generic UnionOfPrimitivePositionalValues
instance eqUnionOfPrimitivePositionalValues :: Eq UnionOfPrimitivePositionalValues where
  eq = gEq
instance showUnionOfPrimitivePositionalValues :: Show UnionOfPrimitivePositionalValues where
  show = gShow
derive instance genericRepUnionOfPrimitivePositionalValues ∷ Generic.Rep.Generic UnionOfPrimitivePositionalValues _

data NestedStructureWithPrimitivePositionvalValue =
  NestedStructureWithPrimitivePositionvalValue PrimitivePositionalValue
derive instance genericNestedStructureWithPrimitivePositionvalValue :: Generic NestedStructureWithPrimitivePositionvalValue
instance eqNestedStructureWithPrimitivePositionvalValue :: Eq NestedStructureWithPrimitivePositionvalValue where
  eq = gEq
instance showNestedStructureWithPrimitivePositionvalValue :: Show NestedStructureWithPrimitivePositionvalValue where
  show = gShow

data NestedStructures =
    FirstOuterConstructor UnionOfPrimitivePositionalValues
  | SecondOuterConstructor PrimitivePositionalValues
derive instance genericNestedStructures :: Generic NestedStructures
instance eqNestedStructures :: Eq NestedStructures where
  eq = gEq
instance showNestedStructures:: Show NestedStructures where
  show = gShow

data StringValue = StringValue String
derive instance genericStringValue :: Generic StringValue
instance eqStringValue :: Eq StringValue where
  eq = gEq
instance showStringValue:: Show StringValue where
  show = gShow

data SumWithInternalRecords
  = FirstConstructorWithRecord
      Int
      { int1 :: Maybe Int
      , string1 :: String
      }
  | SecondConstructorWithRecord
      String
      { int2 :: Maybe Int
      , string2 :: String
      , boolean2 :: Boolean
      }
derive instance genericSumWithInternalRecords :: Generic SumWithInternalRecords

newtype Params =
  Params
    { paramString :: String
    , paramInt :: Int
    , paramBoolean :: Boolean
    }
derive instance genericParms :: Generic Params
derive instance eqParams :: Eq Params
instance showParams :: Show Params where
  show = gShow

params :: String -> Int -> Boolean -> Params
params = ((Params <$> _) <$>  _) <$> {paramString: _, paramInt: _, paramBoolean: _ }

newtype ParamsWithMaybes =
  ParamsWithMaybes
    { optParamString :: Maybe String
    , optParamInt :: Maybe Int
    , optParamBoolean :: Maybe Boolean
    }
derive instance genericParamsWithMaybes :: Generic ParamsWithMaybes
derive instance eqParamsWithMaybes :: Eq ParamsWithMaybes
instance showParamsWithMaybes :: Show ParamsWithMaybes where
  show = gShow

data Optional a = Value a | Missing
derive instance genericOptional :: Generic a => Generic (Optional a)
derive instance eqOptional :: Eq a => Eq (Optional a)
instance showOptional :: Generic a => Show (Optional a) where
  show = gShow

newtype ParamsWithOptionals =
  ParamsWithOptionals
    { optParamString :: Optional String
    , optParamInt :: Optional Int
    , optParamBoolean :: Optional Boolean
    }
derive instance genericParamsWithOptionals :: Generic ParamsWithOptionals
derive instance eqParamsWithOptionals :: Eq ParamsWithOptionals
instance showParamsWithOptionals :: Show ParamsWithOptionals where
  show = gShow

newtype RecordWithArrays =
  RecordWithArrays
    { arrayOfStrings :: Array String
    , arrayOfInts :: Array Int
    , arrayOfBooleans :: Array Boolean
    }
derive instance genericRecordWithArrays :: Generic RecordWithArrays
derive instance eqRecordWithArrays :: Eq RecordWithArrays
instance showRecordWithArrays :: Show RecordWithArrays where
  show = gShow

any :: forall r. UrlBoomerang r (HCons String r)
any = liftStringBoomerang $ manyNoneOf ""

-- regression tests

data MainWindowRoute = Profile | Inbox | Settings
derive instance genericMainWindowRoute :: Generic MainWindowRoute
data SideBarRoute = Expanded | Minimized
derive instance genericSideBarRoute :: Generic SideBarRoute
data AppRoute = AppRoute MainWindowRoute SideBarRoute
derive instance genericAppRoute :: Generic AppRoute

data UrlsWithRoot = Root | Page1 String | Page2 Int
derive instance genericUrlsWithRoot ∷ Generic UrlsWithRoot
instance eqUrlsWithRoot :: Eq UrlsWithRoot where
  eq = gEq
instance showUrlsWithRoot :: Show UrlsWithRoot where
  show = gShow

main :: forall e. Eff ( timer :: TIMER
                      , avar :: AVAR
                      , console :: CONSOLE
                      , testOutput :: TESTOUTPUT | e
                      ) Unit
main = runTest $ suite "Routing.Bob handles" do
  let
    path s = { path: s, query: empty :: StrMap (Maybe String) }
    query q = { path: "", query: q }
  let
    withRouter :: forall a e'. (Generic a) =>
      Proxy a ->
      (Router a -> Aff (timer :: TIMER , avar :: AVAR , testOutput :: TESTOUTPUT | e') Unit) ->
      Aff (timer :: TIMER , avar :: AVAR , testOutput :: TESTOUTPUT | e') Unit
    withRouter p t = (case router' p of
      Nothing -> failure ("Router generation failed")
      (Just b)-> t b)

  suite "url path" do
    test "which contains constructor with single, primitive value" do
      let obj = PrimitivePositionalValue 8
      withRouter (Proxy :: Proxy PrimitivePositionalValue) (\r -> do
        equal "8" (toUrl r obj)
        equal (Just obj) (fromUrl r "8")
        equal (Just obj) (fromUrl r "8?"))
    test "and consumes whole input" do
      let obj = PrimitivePositionalValue 8
      withRouter (Proxy :: Proxy PrimitivePositionalValue) (\r -> do
        equal (Nothing) (fromUrl r "8/something-more"))

    test "which contains construtor with multiple, primitive values" do
      let obj = PrimitivePositionalValues 8 true 9
      withRouter (Proxy :: Proxy PrimitivePositionalValues) (\r -> do
        equal "8/on/9" (toUrl r obj)
        equal (Just obj) (fromUrl r "8/on/9"))

    test "which contains multiple empty constructors" do
       let fObj = FirstEmptyConstructor
           sObj = SecondEmptyConstructor
       withRouter (Proxy :: Proxy UnionOfEmptyConstructors) (\r -> do
         equal "first-empty-constructor" (toUrl r fObj)
         equal "second-empty-constructor" (toUrl r sObj)

         equal (Just fObj) (fromUrl r "first-empty-constructor")
         equal (Just sObj) (fromUrl r "second-empty-constructor"))

    test "which contains multiple non empty constructors" do
      let fObj = FirstConstructor 8 true 9
          sObj = SecondConstructor false
      withRouter (Proxy :: Proxy UnionOfPrimitivePositionalValues) (\r -> do
        equal "first-constructor/8/on/9" (toUrl r fObj)
        equal "second-constructor/off" (toUrl r sObj)

        equal (Just fObj) (fromUrl r "first-constructor/8/on/9")
        equal (Just sObj) (fromUrl r "second-constructor/off"))

    test "root path encoding" do
      let rObj = Root
          serializeConstructorName "Test.Main.Root" = ""
          serializeConstructorName s = defaultOptions.serializeConstructorName s
      case router ({ serializeConstructorName: serializeConstructorName }) (Proxy :: Proxy UrlsWithRoot) of
        Nothing -> failure ("Router generation failed")
        Just r -> do
          equal "" (toUrl r Root)
          equal (Just Root) (fromUrl r "")

          equal "page1/param" (toUrl r (Page1 "param"))
          equal "page2/8" (toUrl r (Page2 8))
          equal (Just (Page1 "param")) (fromUrl r "page1/param")

    test "through generic helpers" do
        equal
          (Just "first-constructor/8/on/9")
          (genericToUrl' (FirstConstructor 8 true 9))
        equal
          (Just "second-constructor/off")
          (genericToUrl' (SecondConstructor false))

        equal (Just (FirstConstructor 8 true 9)) (genericFromUrl' "first-constructor/8/on/9")
        equal (Just (SecondConstructor false)) (genericFromUrl' "second-constructor/off")

    -- test "through generic helpers mixed with boomerang generic" do
    --     equal
    --       (Just "first-constructor/8/on/9")
    --       (genericToUrl' (FirstConstructor 8 true 9))
    --     equal
    --       (Just "second-constructor/off")
    --       (genericToUrl' (SecondConstructor false))

    --     equal (Just (FirstConstructor 8 true 9)) (genericFromUrl' "first-constructor/8/on/9")
    --     equal (Just (SecondConstructor false)) (genericFromUrl' "second-constructor/off")

    test "which contains nested structure with primitive values" do
      let obj = NestedStructureWithPrimitivePositionvalValue (PrimitivePositionalValue 8)
      withRouter (Proxy :: Proxy NestedStructureWithPrimitivePositionvalValue) (\r -> do
        equal "8" (toUrl r obj)
        equal (Just obj) (fromUrl r "8"))

    test "which contains nesteted structures with mutilple constructors" do
      let fObj = FirstOuterConstructor (FirstConstructor 100 true 888)
          sObj = SecondOuterConstructor (PrimitivePositionalValues 8 false 100)

      withRouter (Proxy :: Proxy NestedStructures) (\r -> do
        equal "first-outer-constructor/first-constructor/100/on/888" (toUrl r fObj)
        equal (Just fObj) (fromUrl r "first-outer-constructor/first-constructor/100/on/888")

        equal "second-outer-constructor/8/off/100" (toUrl r sObj)
        equal (Just sObj) (fromUrl r "second-outer-constructor/8/off/100"))

    test "which contains multiple nesteted structures with multiple constructors" do
      withRouter (Proxy :: Proxy AppRoute) (\r -> do
        equal "profile/minimized" (toUrl r (AppRoute Profile Minimized)))

    test "and uses correct escaping for string values" do
      let obj = StringValue "this is test%string"
      withRouter (Proxy :: Proxy StringValue) (\r -> do
        equal "this%20is%20test%25string" (toUrl r obj)
        equal (Just obj) (fromUrl r "this%20is%20test%25string"))
  suite "query with optional values" do
    let
      p = ParamsWithMaybes { optParamBoolean: Just false, optParamInt: Nothing, optParamString: Nothing }
    suite "parsing" do
      test "through generic helper from String" do
        equal
          (Just p)
          (genericFromUrl' "?optParamString&optParamBoolean=off")
    suite "serialization" do
      test "through generic helper from String" do
        equal
          (Just "?optParamBoolean=off")
          (genericToUrl' p)

  suite "query" do
    let
      q =  Tuple "paramString" (Just "test") :  Tuple "paramInt" (Just "8") : Tuple "paramBoolean" (Just "off") : Nil
      p = Params { paramBoolean: false, paramInt: 8, paramString: "test" }
    suite "serialization" do
      test "through generic helper" do
        equal
          (Just <<< Query $ q)
          (genericToUrl' p >>= (\q' -> hush <<< runParser Query.parser <<< dropWhile ('?' == _) $ q'))
      test "for constructor with records and maybe values" do
        let fObj = FirstConstructorWithRecord 8 { int1: Just 8, string1: "string1value" }
            sObj = SecondConstructorWithRecord "test" { int2: Nothing, string2: "string2value", boolean2: false }

        withRouter (Proxy :: Proxy SumWithInternalRecords) (\r -> do
          equal "first-constructor-with-record/8/?string1=string1value&int1=8" (toUrl r fObj)
          equal "second-constructor-with-record/test/?string2=string2value&boolean2=off" (toUrl r sObj))
      test "for constructor with records and values isomorphic to maybe" do
        let fObj = ParamsWithOptionals { optParamString: Value "test", optParamInt: Missing, optParamBoolean: Missing}
            sObj = ParamsWithOptionals { optParamString: Missing, optParamInt: Value 8, optParamBoolean: Missing}

        withRouter (Proxy :: Proxy ParamsWithOptionals) (\r -> do
          equal "?optParamString=test" (toUrl r fObj)
          equal (Just sObj) (fromUrl r "?optParamInt=8&optParamBoolean"))
    suite "parsing" do
      test "through generic helper from String" do
        equal
          (Just p)
          (genericFromUrl' "?paramString=test&paramInt=8&paramBoolean=off")

  suite "query with arrays" do
    let
      p = RecordWithArrays { arrayOfStrings: ["string1", "string2"], arrayOfInts: [1], arrayOfBooleans: [] }
    suite "parsing" do
      test "through generic helper from String" do
        equal
          (Just p)
          (genericFromUrl' "?arrayOfInts=1&arrayOfStrings=string1&arrayOfStrings=string2")
    suite "serialization" do
      test "through generic helper to String" do
        equal
          (Just "?arrayOfStrings=string1&arrayOfStrings=string2&arrayOfInts=1")
          (genericToUrl' p)


Added cartesian product from p. 44 ex. 2

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, length, map, null, range)
import Data.Array.Unsafe (head, last, tail)
import Prelude.Unsafe (unsafeIndex)
import Control.MonadPlus (guard)
import Debug.Trace

-- re-implement the `length` function as `size`
size :: forall a. [a] -> Number
size arr =
  if null arr
     then 0
     else 1 + size (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

positives :: forall a. [Number] -> [Number]
positives arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

--factors :: Number -> [[Number]]
--factors n = filter (\pair -> product pair == n) (pairs n)

factors :: Number -> [[Number]]
factors n = do
  i <- (1..n)
  j <- (i..n)
  guard $ i * j == n
  return [i, j]

isPrime :: Number -> Boolean
isPrime n = length (factors n) == 1

--foreign import unsafeAt
--  "function unsafeAt (arr) {\
--  \  return function (i) {\
--  \    return arr[i];\
--  \  };\
--  \}" :: forall a. [a] -> Number -> a

cartesian :: forall a. [Number] -> [Number] -> [[Number]]
cartesian a b = do
  i <- (0..(length a)-1)
  j <- (0..(length b)-1)
  return [(unsafeIndex a i), (unsafeIndex b j)]

main = do
  let array = (1..10)
  --print $ size array
  --print $ fact 10
  --print $ fib 10
  --print $ square array
  --print $ positives (-5..5)
  --print $ pairs 3
  --print $ factors 10
  --print $ isPrime 13
  --print $ isPrime 14
  --print $ unsafeAt [1,2,3] 1
  print $ cartesian [1,2,3] [4,5,6]

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, length, map, null, range)
import Data.Array.Unsafe (head, last, tail)
import Control.MonadPlus (guard)
import Debug.Trace

-- re-implement the `length` function as `size`
size :: forall a. [a] -> Number
size arr =
  if null arr
     then 0
     else 1 + size (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

positives :: forall a. [Number] -> [Number]
positives arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

--factors :: Number -> [[Number]]
--factors n = filter (\pair -> product pair == n) (pairs n)

factors :: Number -> [[Number]]
factors n = do
  i <- (1..n)
  j <- (i..n)
  guard $ i * j == n
  return [i, j]

isPrime :: Number -> Boolean
isPrime n = length (factors n) == 1

main = do
  let array = (1..10)
  --print $ size array
  --print $ fact 10
  --print $ fib 10
  --print $ square array
  --print $ positives (-5..5)
  --print $ pairs 3
  --print $ factors 10
  print $ isPrime 13
  print $ isPrime 14


Simpler type sigs

Simpler type sigs

-- This is a bit bigger example, featuring _authentication_ and
-- _authorization_, illustrating the parts that can be custom
-- to your application, and how you can leverage the type system
-- to make sure authorization is properly checked.
module Main where

import Prelude
import Hyper.Node.BasicAuth as BasicAuth
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Maybe (Maybe(Nothing, Just))
import Data.MediaType.Common (textHTML)
import Data.StrMap (StrMap)
import Data.Tuple (Tuple(Tuple))
import Hyper.Authentication (setAuthentication)
import Hyper.Core (writeStatus, Status, StatusLineOpen, statusOK, statusNotFound, class ResponseWriter, ResponseEnded, Conn, Middleware, closeHeaders, Port(Port))
import Hyper.HTML.DSL (HTML, li, ul, linkTo, h1, p, text, html)
import Hyper.Method (Method)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (headers, respond, contentType)
import Hyper.Router (notSupported, resource, fallbackTo, handler)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)

-- Helper for responding with HTML.
htmlWithStatus
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     Status
  -> HTML Unit
  -> Middleware
     m
     (Conn req { writer :: rw StatusLineOpen | res } c)
     (Conn req { writer :: rw ResponseEnded | res } c)
htmlWithStatus status x =
  writeStatus status
  >=> contentType textHTML
  >=> closeHeaders
  >=> html x

-- Users have user names.
type Name = String
data User = User Name

-- Authorization is specific to this example, and wraps the authenticated
-- User, in conn.components.authentication, with an Authorized value holding
-- the role.
data Admin = Admin
data Authorized r = Authorized User r

-- This could be a function checking the username/password in a database.
userFromBasicAuth :: forall e. Tuple String String -> Aff e (Maybe User)
userFromBasicAuth =
  case _ of
    Tuple "admin" "admin" -> pure (Just (User "administrator"))
    Tuple "guest" "guest" -> pure (Just (User "guest"))
    _ -> pure Nothing

-- A middleware that wraps another middleware, checking that the
-- authenticated user has role `Admin`. In this example it simply
-- checks the user name, but in a real application you would
-- likely do a database lookup or something like that.
requireAdmin
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     (Middleware
      m
      (Conn req { writer :: rw StatusLineOpen | res } { authentication :: Authorized Admin | c })
      (Conn req { writer :: rw ResponseEnded | res } { authentication :: Authorized Admin | c }))
  -> Middleware
     m
     (Conn req { writer :: rw StatusLineOpen | res } { authentication :: User | c })
     (Conn req { writer :: rw ResponseEnded | res } { authentication :: User | c })
requireAdmin mw conn =
  case conn.components.authentication of
    User "administrator" ->
      conn
      # setAuthentication (Authorized conn.components.authentication Admin)
      # mw
      # map (setAuthentication conn.components.authentication)
    _ ->
      writeStatus (Tuple 403 "Forbidden") conn
      >>= headers []
      >>= respond "You are not authorized."

-- A handler that does not require an authenticated user, but displays the
-- name if the user _is_ authenticated.
profileHandler
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     Middleware
     m
     (Conn req { writer :: rw StatusLineOpen | res } { authentication :: Maybe User | c })
     (Conn req { writer :: rw ResponseEnded | res } { authentication :: Maybe User | c })
profileHandler conn =
  htmlWithStatus
  statusOK
  (view conn.components.authentication)
  conn
  where
    view =
      case _ of
        Just (User name) -> do
          h1 [] (text "Profile")
          p [] (text ("Logged in as " <> name <> "."))
        Nothing ->
          p [] (text "You are not logged in.")

-- A handler that requires a `User` authorized as `Admin`. Note that
-- even if the actual authorization check does not happen here, we
-- cannot user this handler without doing authorization properly
-- before.
adminHandler
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     Middleware
     m
     (Conn req { writer :: rw StatusLineOpen | res } { authentication :: Authorized Admin | c })
     (Conn req { writer :: rw ResponseEnded | res } { authentication :: Authorized Admin | c })
adminHandler conn =
  htmlWithStatus
  statusOK
  (view conn.components.authentication)
  conn
  where
    view (Authorized (User name) Admin) = do
      h1 [] (text "Administration")
      p [] (text ("Here be dragons, " <> name <> "."))

app :: forall e req res rw c.
       (ResponseWriter rw (Aff (buffer :: BUFFER | e))) =>
       Middleware
       (Aff (buffer :: BUFFER | e))
       (Conn { url :: String, method :: Method, headers :: StrMap String | req }
             { writer :: rw StatusLineOpen | res }
             { authentication :: Unit | c })
       (Conn { url :: String, method :: Method, headers :: StrMap String | req }
             { writer :: rw ResponseEnded | res }
             { authentication :: Maybe User | c })
app =
  -- We always check for authentication.
  BasicAuth.withAuthentication userFromBasicAuth
  >=> fallbackTo notFound (resource home <|> resource profile <|> resource admin)
    where
      notFound = htmlWithStatus
                 statusNotFound
                 (text "Not Found")

      homeView = do
        h1 [] (text "Home")
        ul [] do
          li [] (linkTo profile (text "Profile"))
          li [] (linkTo admin (text "Administration"))

      home = { path: []
             , "GET":
               handler (htmlWithStatus statusOK homeView)
             , "POST": notSupported
             }

      profile = { path: ["profile"]
                , "GET": handler profileHandler
                , "POST": notSupported
                }

      admin = { path: ["admin"]
              -- To use the admin handler, we must ensure that the user is
              -- authenticated and authorized as `Admin`.
              , "GET": handler (BasicAuth.authenticated (requireAdmin adminHandler))
              , "POST": notSupported
              }

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR, buffer :: BUFFER | e) Unit
main =
  let
    -- Some nice console printing when the server starts, and if a request
    -- fails (in this case when the request body is unreadable for some reason).
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)
    components = { authentication: unit }

  -- Let's run it.
  in runServer defaultOptions onListening onRequestError components app

-- This is a bit bigger example, featuring _authentication_ and
-- _authorization_, illustrating the parts that can be custom
-- to your application, and how you can leverage the type system
-- to make sure authorization is properly checked.
module Main where

import Prelude
import Hyper.Node.BasicAuth as BasicAuth
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Maybe (Maybe(Nothing, Just))
import Data.MediaType.Common (textHTML)
import Data.StrMap (StrMap)
import Data.Tuple (Tuple(Tuple))
import Hyper.Authentication (setAuthentication)
import Hyper.Core (writeStatus, Status, StatusLineOpen, statusOK, statusNotFound, class ResponseWriter, ResponseEnded, Conn, Middleware, closeHeaders, Port(Port))
import Hyper.HTML.DSL (HTML, li, ul, linkTo, h1, p, text, html)
import Hyper.Method (Method)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (headers, respond, contentType)
import Hyper.Router (notSupported, resource, fallbackTo, handler)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)

-- Helper for responding with HTML.
htmlWithStatus
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     Status
  -> HTML Unit
  -> Middleware
     m
     (Conn { url :: String, method :: Method | req }
           { writer :: rw StatusLineOpen | res }
           c)
     (Conn { url :: String, method :: Method | req }
           { writer :: rw ResponseEnded | res }
           c)
htmlWithStatus status x =
  writeStatus status
  >=> contentType textHTML
  >=> closeHeaders
  >=> html x

-- Users have user names.
type Name = String
data User = User Name

-- Authorization is specific to this example, and wraps the authenticated
-- User, in conn.components.authentication, with an Authorized value holding
-- the role.
data Admin = Admin
data Authorized r = Authorized User r

-- This could be a function checking the username/password in a database.
userFromBasicAuth :: forall e. Tuple String String -> Aff e (Maybe User)
userFromBasicAuth =
  case _ of
    Tuple "admin" "admin" -> pure (Just (User "administrator"))
    Tuple "guest" "guest" -> pure (Just (User "guest"))
    _ -> pure Nothing

-- A middleware that wraps another middleware, checking that the
-- authenticated user has role `Admin`. In this example it simply
-- checks the user name, but in a real application you would
-- likely do a database lookup or something like that.
requireAdmin
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     (Middleware
      m
      (Conn req
            { writer :: rw StatusLineOpen | res }
            { authentication :: Authorized Admin | c })
      (Conn req
            { writer :: rw ResponseEnded | res }
            { authentication :: Authorized Admin | c }))
  -> Middleware
     m
     (Conn req
           { writer :: rw StatusLineOpen | res }
           { authentication :: User | c })
     (Conn req
           { writer :: rw ResponseEnded | res }
           { authentication :: User | c })
requireAdmin mw conn =
  case conn.components.authentication of
    User "administrator" ->
      conn
      # setAuthentication (Authorized conn.components.authentication Admin)
      # mw
      # map (setAuthentication conn.components.authentication)
    _ ->
      writeStatus (Tuple 403 "Forbidden") conn
      >>= headers []
      >>= respond "You are not authorized."

-- A handler that does not require an authenticated user, but displays the
-- name if the user _is_ authenticated.
profileHandler
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     Middleware
     m
     (Conn { url :: String, method :: Method, headers :: StrMap String | req }
           { writer :: rw StatusLineOpen | res }
           { authentication :: Maybe User | c })
     (Conn { url :: String, method :: Method, headers :: StrMap String | req }
           { writer :: rw ResponseEnded | res }
           { authentication :: Maybe User | c })
profileHandler conn =
  htmlWithStatus
  statusOK
  (view conn.components.authentication)
  conn
  where
    view =
      case _ of
        Just (User name) -> do
          h1 [] (text "Profile")
          p [] (text ("Logged in as " <> name <> "."))
        Nothing ->
          p [] (text "You are not logged in.")

-- A handler that requires a `User` authorized as `Admin`. Note that
-- even if the actual authorization check does not happen here, we
-- cannot user this handler without doing authorization properly
-- before.
adminHandler
  :: forall m req res rw c.
     (Monad m, ResponseWriter rw m) =>
     Middleware
     m
     (Conn { url :: String, method :: Method, headers :: StrMap String | req }
           { writer :: rw StatusLineOpen | res }
           { authentication :: Authorized Admin | c })
     (Conn { url :: String, method :: Method, headers :: StrMap String | req }
           { writer :: rw ResponseEnded | res }
           { authentication :: Authorized Admin | c })
adminHandler conn =
  htmlWithStatus
  statusOK
  (view conn.components.authentication)
  conn
  where
    view (Authorized (User name) Admin) = do
      h1 [] (text "Administration")
      p [] (text ("Here be dragons, " <> name <> "."))

app :: forall e req res rw c.
       (ResponseWriter rw (Aff (buffer :: BUFFER | e))) =>
       Middleware
       (Aff (buffer :: BUFFER | e))
       (Conn { url :: String, method :: Method, headers :: StrMap String | req }
             { writer :: rw StatusLineOpen | res }
             { authentication :: Unit | c })
       (Conn { url :: String, method :: Method, headers :: StrMap String | req }
             { writer :: rw ResponseEnded | res }
             { authentication :: Maybe User | c })
app =
  -- We always check for authentication.
  BasicAuth.withAuthentication userFromBasicAuth
  >=> fallbackTo notFound (resource home <|> resource profile <|> resource admin)
    where
      notFound = htmlWithStatus
                 statusNotFound
                 (text "Not Found")

      homeView = do
        h1 [] (text "Home")
        ul [] do
          li [] (linkTo profile (text "Profile"))
          li [] (linkTo admin (text "Administration"))

      home = { path: []
             , "GET":
               handler (htmlWithStatus statusOK homeView)
             , "POST": notSupported
             }

      profile = { path: ["profile"]
                , "GET": handler profileHandler
                , "POST": notSupported
                }

      admin = { path: ["admin"]
              -- To use the admin handler, we must ensure that the user is
              -- authenticated and authorized as `Admin`.
              , "GET": handler (BasicAuth.authenticated (requireAdmin adminHandler))
              , "POST": notSupported
              }

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR, buffer :: BUFFER | e) Unit
main =
  let
    -- Some nice console printing when the server starts, and if a request
    -- fails (in this case when the request body is unreadable for some reason).
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)
    components = { authentication: unit }

  -- Let's run it.
  in runServer defaultOptions onListening onRequestError components app