module ContMain where

import Language.Haskell.Pretty

import Target
import ContType
import ContParser
import ContCompiler

primitives = map (\ n -> (n, mkOp n)) ["*", "+", "-", "++", ":", "==", "/=", "<", "<=", ">=", ">"]
          ++ map (\ n -> (n, divOp n)) ["/", "%"] 
          ++ map (\ n -> (n, mkPrimN 2 n)) ["tryM","appendM"]
          ++ map (\ n -> (n, mkPureN 1 n))
                 ["not","null", "head", "tail", "show", "atoi", "atof"]


simplifyK :: Target -> Target
simplifyK (m `TBindM` k) = simplifyK (TLambda1 "c" (TApp1 (shift 1 0 m)
                                         (TLambda1 "a" (TApp1 (TApp1 (shift 2 0 k) (TBound 0))
                                                              (TBound 1)))))
simplifyK (TUnitM t)     = simplifyK (TLambda1 "c" (TApp1 (TBound 0) (shift 1 0 t)))
simplifyK (TLambda1 v t) = TLambda1 v (simplifyK t)
simplifyK (TLambda0 t)   = TLambda0 (simplifyK t)
simplifyK (TLambda p t)  = TLambda p (simplifyK t)
simplifyK (TApp f xs)    = TApp (simplifyK f) (map simplifyK xs)
simplifyK (TApp1 f x)    = TApp1 (simplifyK f) (simplifyK x)
simplifyK (TInfix l o r) = TInfix (simplifyK l) o (simplifyK r)
simplifyK (TLet ds t)    = TLet (map (\ (p,t) -> (p,simplifyK t)) ds) (simplifyK t)
simplifyK (TIf c t e)    = TIf (simplifyK c) (simplifyK t) (simplifyK e)
simplifyK (TCase t alts) = TCase (simplifyK t) (map (\ (p,t) -> (p,simplifyK t)) alts)
simplifyK t              = t

simplifyKDecls :: [(t, Target)] -> [(t, Target)]
simplifyKDecls ds = map (\ (p,t) -> (p,simplifyK t)) ds

test = testK
testDecls = testKDecls

testK useDo prog = prettyPrint $ translateToHs useDo
           	 $ removeSugar False $ simplify $ instOnce primitives
           	 $ deBruijn $ compK $ myParse prog

testKDecls useDo prog = concat $ map (\ str -> str ++ "\n") $ map prettyPrint $ translateToHsDecls useDo
           	      $ removeSugarDecls False $ simplifyDecls $ instOnceDecls primitives
           	      $ deBruijnDecls $ compKDecls $ myParseDecls prog

testCC useDo prog = prettyPrint $ translateToHs useDo
            	  $ removeSugar False $ simplify $ instOnce primitives
            	  $ deBruijn $ compCC $ myParse prog

testCCDecls useDo prog = concat $ map (\ str -> str ++ "\n") $ map prettyPrint $ translateToHsDecls useDo
           	       $ removeSugarDecls False $ simplifyDecls $ instOnceDecls primitives
           	       $ deBruijnDecls $ compCCDecls $ myParseDecls prog

envCC = [("abortK", TLambda1 "v" (TLambda0 (TBound 0))),
         ("callccK",  TLambda1 "h"
                          (TLambda [PVar "c"]
                              (TApp (TBound 1)
                                    [TLambda1 "a" (TLambda0 (TApp1 (TBound 1) (TBound 0))),
                                                                          TBound 0])))]

toCPS = toCPSK
toCPSDecls = toCPSKDecls

toCPSK prog = prettyPrint $ translateToHs False $ removeSugar True
            $ simplify $ instOnce envCC $ simplifyK 
            $ simplify $ instOnce primitives $ deBruijn $ compK $ myParse prog

toCPSKDecls prog = concat $ map (\ str -> str ++ "\n") $ map prettyPrint $ translateToHsDecls False $ removeSugarDecls True
                 $ simplifyDecls $ instOnceDecls envCC $ simplifyKDecls
                 $ simplifyDecls $ instOnceDecls primitives $ deBruijnDecls
                 $ compKDecls $ myParseDecls prog


toCPSCC prog = prettyPrint $ translateToHs False $ removeSugar True
             $ simplify $ instOnce envCC $ simplifyK 
             $ simplify $ instOnce primitives $ deBruijn $ compCC $ myParse prog

toCPSCCDecls prog = concat $ map (\ str -> str ++ "\n") $ map prettyPrint $ translateToHsDecls False $ removeSugarDecls True
                   $ simplifyDecls $ instOnceDecls envCC $ simplifyKDecls
                   $ simplifyDecls $ instOnceDecls primitives $ deBruijnDecls
                   $ compCCDecls $ myParseDecls prog

utilGoto = "begin\n"
        ++ "  setX 1;\n"
        ++ "label1:\n"
        ++ "  if getX () > 100 then\n"
        ++ "    goto label2\n"
        ++ "  else ();\n"
        ++ "  setX (getX () * 2);\n"
        ++ "  goto label1;\n"
        ++ "label2:\n"
        ++ "  getX ()\n"
        ++ "end\n"

utilWhileDecl = "foo = \\ n ->\n"
             ++ "  begin\n"
             ++ "    setX 1;\n"
             ++ "    setY n;\n"
             ++ "    while getY () > 0 do\n"
             ++ "      begin\n"
             ++ "        val r = getX () in\n"
             ++ "        val n = getY () in\n"
             ++ "        begin\n"
             ++ "          if n==10 then break\n"
             ++ "          else if n==3 then\n"
             ++ "            begin\n"
             ++ "              setX r;\n"
             ++ "              setY (n-1);\n"
             ++ "              continue\n"
             ++ "            end\n"
             ++ "          else ();\n"
             ++ "          setX (r*n);\n"
             ++ "          setY (n-1)\n"
             ++ "        end\n"
             ++ "      end;\n"
             ++ "    getX ()\n"
             ++ "  end\n"
utilWhile = "let " ++ utilWhileDecl ++ "in foo 9\n"

utilFactDecl = "fact = \\ n -> if n==0 then 1 else n*fact(n-1)"
utilFact = "let " ++ utilFactDecl ++ " in fact 9"

utilMultDecl =
    "baz = \\ list ->\n" 
  ++"  let mult = \\ xs -> \\ k -> begin\n"
  ++"        setX 1; setY xs; setZ \"\";\n"
  ++"        while not (null (getY())) do begin\n"
  ++"          val y = getY() in\n"
  ++"          val n = head y in\n"
  ++"          if n == 0 then k 0 else\n"
  ++"            begin setX (getX()*n); setY (tail y); setZ (getZ() ++ \" \" ++ show n) end\n"
  ++"        end;\n"
  ++"        getX ()\n"
  ++"    end in\n"
  ++"  val result = callccK (\\ k -> mult list k)  in\n"
  ++"  \"result = \" ++ show result ++ \"; z = \\\"\" ++ getZ () ++ \"\\\";\"\n"

utilMult = "let " ++ utilMultDecl ++ " in baz (1:2:3:0:4:5:[])"

-- for example,
-- putStrLn $ test False utilGoto
-- putStrLn $ test False utilWhile
-- putStrLn $ toCPS utilFact