<|start_filename|>frontend/services/RuntimeProcessManager.hs<|end_filename|>
module RuntimeProcessManager (withRuntimeProcess) where

import JavaUtils      (getClassPath)
import StringPrefixes (namespace)

import System.IO      (Handle, hSetBuffering, BufferMode(..))
import System.Process

withRuntimeProcess :: String -> BufferMode -> ((Handle,Handle) -> IO a) -> IO a
withRuntimeProcess class_name buffer_mode do_this
  = do cp <- getClassPath
       let p = (proc "java" ["-cp", cp, namespace ++ class_name, cp])
                  {std_in = CreatePipe, std_out = CreatePipe}
       (Just inP, Just outP, _, proch) <- createProcess p
       hSetBuffering inP buffer_mode
       hSetBuffering outP buffer_mode
       result <- do_this (inP, outP)
       terminateProcess proch
       return result


<|start_filename|>examples/fractals/lib/PlotWindow.java<|end_filename|>
package lib;

import javax.swing.JFrame;

import java.awt.Graphics;
import java.awt.Color;
import java.awt.image.BufferedImage;

public class PlotWindow extends JFrame
{
    static final int SIZE = 600;
    BufferedImage bufferedImage = new BufferedImage(SIZE, SIZE, BufferedImage.TYPE_INT_RGB);
    static PlotWindow plotWindow;
    static double lx, rx, ty, by;

    private PlotWindow(int lx, int ty, int rx, int by)
    {
        PlotWindow.lx = (double)lx / 100;
        PlotWindow.ty = (double)ty / 100;
        PlotWindow.rx = (double)rx / 100;
        PlotWindow.by = (double)by / 100;
        setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE);
        setSize(SIZE, SIZE);
        setVisible(true);
    }

    public void paint(Graphics g)
    {
        super.paint(g);
        g.drawImage(bufferedImage, 0, 0, null);
    }

    public static void create(int lx, int ty, int rx, int by)
    {
        plotWindow = new PlotWindow(lx, ty, rx, by);
    }

    public static int setRGBColor(int x, int y, Color c)
    {
        plotWindow.setRGBColor(x, y, c.getRGB());
        return 0;
    }

    void setRGBColor(int x, int y, int c)
    {
        bufferedImage.setRGB(x, y, c);
        if (x == SIZE - 1 && y == SIZE - 1)
            repaint();
    }

    public static Complex toComplex(int x, int y)
    {
        double xscale = (double)x / SIZE, yscale = (double)y / SIZE;
        return new Complex(xscale * (rx-lx) + lx, yscale * (ty-by) + by);
    }
}



<|start_filename|>backend/Core.hs<|end_filename|>
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -Wall #-}
{- |
Module      :  Core
Description :  Abstract syntax and pretty printer for Core.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>, <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module Core
  ( Type(..)
  , Expr(..)
  , Alt(..)
  , TypeContext
  , ValueContext
  , Index
  , Constructor(..)
  , DataBind(..)
  , Definition(..)
  , alphaEq
  , mapTVar
  , mapVar
  , fsubstTT
  , fsubstTE
  , fsubstEE
  , joinType
  , tVar
  , Core.forall
  , var
  , lam
  , fix
  , bLam
  , prettyType
  , prettyExpr
  , javaInt
  ) where

import qualified Src

import           JavaUtils
import           PrettyUtils

import           Control.Arrow (second)
import           Data.List (intersperse)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Language.Java.Pretty (prettyPrint)
import           Prelude hiding ((<$>))
import           Text.PrettyPrint.ANSI.Leijen

data Type t
  = TVar Src.Name t                -- a
  | JClass ClassName                   -- C
  | Fun (Type t) (Type t)              -- t1 -> t2
  | Forall Src.Name (t -> Type t)  -- forall a. t
  | Product [Type t]                   -- (t1, ..., tn)
  | Unit
  | Datatype Src.Name [Type t] [Src.Name]

data Definition t e = Def Src.Name Src.Type (Expr t e) (e -> Definition t e)
                    | DefRec [Src.Name] [(Src.Type, Type t)] ([e] -> [Expr t e]) ([e] -> Definition t e)
                    | Null

data Expr t e
  = Var Src.Name e
  | Lit Src.Lit

  -- Binders we have: λ, fix, letrec, and Λ
  | Lam Src.Name (Type t) (e -> Expr t e)
  | Fix Src.Name Src.Name
        (e -> e -> Expr t e)
        (Type t)  -- t1
        (Type t)  -- t
      -- fix x (x1 : t1) : t. e     Syntax in the tal-toplas paper
      -- fix (x : t1 -> t). \x1. e  Alternative syntax, which is arguably clear
      -- <name>: Fix funcName paraName func paraType returnType
  | Let Src.Name (Expr t e) (e -> Expr t e)
  | LetRec [Src.Name]       -- Names
           [Type t]             -- Signatures
           ([e] -> [Expr t e])  -- Bindings
           ([e] -> Expr t e)    -- Body
  | BLam Src.Name (t -> Expr t e)

  | App  (Expr t e) (Expr t e)
  | TApp (Expr t e) (Type t)

  | If (Expr t e) (Expr t e) (Expr t e)
  | PrimOp (Expr t e) Src.Operator (Expr t e)
      -- SystemF extension from:
      -- https://www.cs.princeton.edu/~dpw/papers/tal-toplas.pdf
      -- (no int restriction)

  | Tuple [Expr t e]     -- Tuple introduction
  | Proj Int (Expr t e)  -- Tuple elimination

  -- Module
  | Module (Maybe Src.PackageName) (Definition t e)

  -- Java
  | JNew ClassName [Expr t e]
  | JMethod (Src.JReceiver (Expr t e)) MethodName [Expr t e] ClassName
  | JField  (Src.JReceiver (Expr t e)) FieldName (Type t)

  | Seq [Expr t e]

  | Data Src.RecFlag [DataBind t] (Expr t e)
  | ConstrOut (Constructor t) [Expr t e]
  | Case (Expr t e) [Alt t e]

  | Error (Type t) (Expr t e)

data DataBind t = DataBind Src.Name [Src.Name] ([t] -> [Constructor t])

data Alt t e = ConstrAlt (Constructor t) (Expr t e)
             | Default (Expr t e)

data Constructor t = Constructor {constrName :: Src.Name, constrParams :: [Type t]}

type TypeContext t    = Set.Set t
type ValueContext t e = Map.Map e (Type t)

type Index = Int

alphaEq :: Int -> Type Index -> Type Index -> Bool
alphaEq _ (TVar _ a)   (TVar _ b)   = a == b
alphaEq _ (JClass c)   (JClass d)   = c == d
alphaEq i (Fun s1 s2)  (Fun t1 t2)  = alphaEq i s1 t1 && alphaEq i s2 t2
alphaEq i (Forall _ f) (Forall _ g) = alphaEq (succ i) (f i) (g i)
alphaEq i (Product ss) (Product ts) = length ss == length ts && uncurry (alphaEq i) `all` zip ss ts
alphaEq _  Unit         Unit        = True
alphaEq _  _            _           = False

mapTVar :: (Src.Name -> t -> Type t) -> Type t -> Type t
mapTVar g (TVar n a)     = g n a
mapTVar _ (JClass c)     = JClass c
mapTVar g (Fun t1 t2)    = Fun (mapTVar g t1) (mapTVar g t2)
mapTVar g (Forall n f)   = Forall n (mapTVar g . f)
mapTVar g (Product ts)   = Product (map (mapTVar g) ts)
mapTVar _  Unit          = Unit
mapTVar g (Datatype n ts ns)  = Datatype n (map (mapTVar g) ts) ns

mapVar :: (Src.Name -> e -> Expr t e) -> (Type t -> Type t) -> Expr t e -> Expr t e
mapVar g _ (Var n a)                 = g n a
mapVar _ _ (Lit n)                   = Lit n
mapVar g h (Lam n t f)               = Lam n (h t) (mapVar g h . f)
mapVar g h (BLam n f)                = BLam n (mapVar g h . f)
mapVar g h (Fix n1 n2 f t1 t)        = Fix n1 n2 (\x x1 -> mapVar g h (f x x1)) (h t1) (h t)
mapVar g h (Let n b e)               = Let n (mapVar g h b) (mapVar g h . e)
mapVar g h (LetRec ns ts bs e)       = LetRec ns (map h ts) (map (mapVar g h) . bs) (mapVar g h . e)
mapVar g h (Data rec databinds e)    = Data rec (map mapDatabind databinds) (mapVar g h e)
    where mapDatabind (DataBind name params ctrs) = DataBind name params (map mapCtr. ctrs)
          mapCtr (Constructor n ts)  = Constructor n (map h ts)
mapVar g h (ConstrOut (Constructor n ts) es) = ConstrOut c' (map (mapVar g h) es)
    where c' = Constructor n (map h ts)
mapVar g h (Case e alts)             = Case (mapVar g h e) (map mapAlt alts)
    where mapAlt (ConstrAlt (Constructor n ts) e1) = ConstrAlt (Constructor n (map h ts)) (mapVar g h e1)
          mapAlt (Default e1) = Default (mapVar g h e1)
mapVar g h (App f e)                 = App (mapVar g h f) (mapVar g h e)
mapVar g h (TApp f t)                = TApp (mapVar g h f) (h t)
mapVar g h (If p b1 b2)              = If (mapVar g h p) (mapVar g h b1) (mapVar g h b2)
mapVar g h (PrimOp e1 op e2)         = PrimOp (mapVar g h e1) op (mapVar g h e2)
mapVar g h (Tuple es)                = Tuple (map (mapVar g h) es)
mapVar g h (Proj i e)                = Proj i (mapVar g h e)
mapVar g h (JNew c args)             = JNew c (map (mapVar g h) args)
mapVar g h (JMethod callee m args c) = JMethod (fmap (mapVar g h) callee) m (map (mapVar g h) args) c
mapVar g h (JField  callee f c)      = JField (fmap (mapVar g h) callee) f (h c)
mapVar g h (Seq es)                  = Seq (map (mapVar g h) es)
mapVar g h (Error ty str)            = Error (h ty) (mapVar g h str)
mapVar g h (Module pname defs)       = Module pname (mapVarDef defs)
  where
    -- Necessary?
    mapVarDef (Def name typ expr def) = Def name typ (mapVar g h expr) (mapVarDef . def)
    mapVarDef (DefRec names types exprs def) =
      DefRec names (map (second h) types) (map (mapVar g h) . exprs) (mapVarDef . def)
    mapVarDef Null = Null



fsubstTT :: Eq a => a -> Type a -> Type a -> Type a
fsubstTT x r = mapTVar (\n a -> if a == x then r else TVar n a)

fsubstTE :: Eq t => t -> Type t -> Expr t e -> Expr t e
fsubstTE x r = mapVar Var (fsubstTT x r)

fsubstEE :: Eq a => a -> Expr t a -> Expr t a -> Expr t a
fsubstEE x r = mapVar (\n a -> if a == x then r else Var n a) id


joinType :: Type (Type t) -> Type t
joinType (TVar _ a)       = a
joinType (JClass c)       = JClass c
joinType (Fun t1 t2)      = Fun (joinType t1) (joinType t2)
joinType (Forall n g)     = Forall n (joinType . g . TVar "_") -- Right?
joinType (Product ts)     = Product (map joinType ts)
joinType  Unit            = Unit
joinType (Datatype n ts ns)  = Datatype n (map joinType ts) ns

tVar :: t -> Type t
tVar = TVar "tv"

forall :: (t -> Type t) -> Type t
forall f = Forall "f" f

var :: e -> Expr t e
var = Var "v"

lam :: Type t -> (e -> Expr t e) -> Expr t e
lam = Lam "x"

fix :: (e -> e -> Expr t e) -> Type t -> Type t -> Expr t e
fix = Fix "f" "x"

bLam :: (t -> Expr t e) -> Expr t e
bLam = BLam "X"

-- instance Show (Type Index) where
--   show = show . pretty

-- instance Pretty (Type Index) where
--   pretty = prettyType

prettyType :: Type Index -> Doc
prettyType = prettyType' basePrec 0

prettyType' :: Prec -> Index -> Type Index -> Doc

prettyType' _ _ (TVar n _)   = text n

prettyType' p i (Datatype n tvars _) = hsep $ text n : map (prettyType' p i) tvars

prettyType' p i (Fun t1 t2)  =
  parensIf p 2
    (prettyType' (2,PrecPlus) i t1 <+> arrow <+> prettyType' (2,PrecMinus) i t2)

prettyType' p i (Forall n f)   =
  parensIf p 1
    (PrettyUtils.forall <+> text n <> dot <+>
     prettyType' (1,PrecMinus) (succ i) (f i))

prettyType' _ i (Product ts) = parens $ hcat (intersperse comma (map (prettyType' basePrec i) ts))

prettyType' _ _  Unit = text "Unit"

prettyType' _ _ (JClass "java.lang.Integer")   = text "Int"
prettyType' _ _ (JClass "java.lang.String")    = text "String"
prettyType' _ _ (JClass "java.lang.Boolean")   = text "Bool"
prettyType' _ _ (JClass "java.lang.Character") = text "Char"
prettyType' _ _ (JClass c)                     = text c

-- instance Show (Expr Index Index) where
--   show = show . pretty

-- instance Pretty (Expr Index Index) where
--   pretty = prettyExpr

prettyDef :: Prec -> (Index, Index) -> Definition Index Index -> Doc
prettyDef _ (i, j) (Def fname typ e def) =
  text fname <+> colon <+> pretty typ <+> equals <+> prettyExpr' basePrec (i, j + 1) e <> semi <$>
  prettyDef basePrec (i, j+1) (def j) -- crappy pretty printer

prettyDef p (i, j) (DefRec names sigs binds def) = vcat (intersperse (text "and") pretty_binds) <> semi <$> pretty_body
  where
    n = length sigs
    ids = [i .. (i + n) - 1]
    pretty_ids = map text names
    pretty_sigs = map (pretty . fst) sigs
    pretty_defs = map (prettyExpr' p (i, j + n)) (binds ids)
    pretty_binds = zipWith3
                     (\pretty_id pretty_sig pretty_def ->
                        pretty_id <+> colon <+> pretty_sig <$> indent 2 (equals <+> pretty_def))
                     pretty_ids
                     pretty_sigs
                     pretty_defs
    pretty_body = prettyDef p (i, j + n) (def ids)

prettyDef _ _ Null = text ""

prettyExpr :: Expr Index Index -> Doc
prettyExpr = prettyExpr' basePrec (0, 0)

prettyExpr' :: Prec -> (Index, Index) -> Expr Index Index -> Doc

prettyExpr' _ _ (Var n _) = text n

prettyExpr' p (i,j) (Lam n t f)
  = parensIf p 2 $ group $ hang 2 $
      lambda <+> parens (text n <+> colon <+> prettyType' basePrec i t) <+> text "->" <$>
      prettyExpr' (2,PrecMinus) (i, j + 1) (f j)

prettyExpr' p (i,j) (App e1 e2)
  = parensIf p 4 $
      group $ hang 2 $ prettyExpr' (4,PrecMinus) (i,j) e1 <$> prettyExpr' (4,PrecPlus) (i,j) e2

prettyExpr' p (i,j) (BLam n f) =
  parensIf p 2
    (biglambda <+> text n <+> text "->" <+>
     prettyExpr' (2,PrecMinus) (succ i, j) (f i))

prettyExpr' p (i,j) (TApp e t) =
  parensIf p 4
    (group $ hang 2 $ prettyExpr' (4,PrecMinus) (i,j) e <$> brackets (prettyType' basePrec i t))

prettyExpr' _ _ (Lit (Src.Int n))    = integer n
prettyExpr' _ _ (Lit (Src.String s)) = dquotes (string s)
prettyExpr' _ _ (Lit (Src.Bool b))   = bool b
prettyExpr' _ _ (Lit (Src.Char c))   = char c
prettyExpr' _ _ (Lit Src.UnitLit)    = unit

prettyExpr' p (i,j) (If e1 e2 e3)
  = parensIf p prec
      (hang 3 (text "if"   <+> prettyExpr' (prec,PrecMinus) (i,j) e1 <+>
               text "then" <+> prettyExpr' (prec,PrecMinus) (i,j) e2 <+>
               text "else" <+> prettyExpr' (prec,PrecMinus) (i,j) e3))
  where prec = 3

prettyExpr' p (i,j) (PrimOp e1 op e2)
  = parens (prettyExpr' p (i,j) e1 <+> pretty_op <+> prettyExpr' p (i,j) e2)
  where
    pretty_op = text (Language.Java.Pretty.prettyPrint java_op)
    java_op   = case op of
                  Src.Arith   op' -> op'
                  Src.Compare op' -> op'
                  Src.Logic   op' -> op'

prettyExpr' _ (i,j) (Tuple es) = tupled (map (prettyExpr' basePrec (i,j)) es)

prettyExpr' p i (Proj n e) =
  parensIf p 5
    (prettyExpr' (5,PrecMinus) i e <> dot <> char '_' <> int n)

prettyExpr' p i (Module pname defs) =
  maybe empty ((text "package" <+>) . pretty) pname <$> text "module" <> semi <$> prettyDef p i defs

prettyExpr' _ (i,j) (JNew c args) =
  parens (text "new" <+> text c <> tupled (map (prettyExpr' basePrec (i,j)) args))

prettyExpr' _ i (JMethod name m args _) = methodStr name <> dot <> text m <> tupled (map (prettyExpr' basePrec i) args)
  where
    methodStr (Src.Static x) = text x
    methodStr (Src.NonStatic x) = prettyExpr' (6,PrecMinus) i x

prettyExpr' _ i (JField name f _) = fieldStr name <> dot <> text f
  where
    fieldStr (Src.Static x) = text x
    fieldStr (Src.NonStatic x) = prettyExpr' (6,PrecMinus) i x

prettyExpr' p i (Error _ str) = text "error:" <+> prettyExpr' p i str

prettyExpr' p (i,j) (Seq es) = semiBraces (map (prettyExpr' p (i,j)) es)

prettyExpr' p (i,j) (Fix n1 n2 f t1 t)
  = parens $ group $ hang 2 $
      text "fix" <+> text n1 <+>
      parens (text n2 <+> colon <+> prettyType' p i t1) <+>
      colon <+> prettyType' p i t <> dot <$>
      prettyExpr' p (i, j + 2) (f j (j + 1))

prettyExpr' _ (i,j) (Let n b e) =
  text "let" <+> text n <+> equals <+> prettyExpr' basePrec (i, j + 1) b <$> text "in" <$>
  prettyExpr' basePrec (i, j + 1) (e j)

prettyExpr' p (i,j) (LetRec names sigs binds body)
  = text "let" <+> text "rec" <$>
    vcat (intersperse (text "and") (map (indent 2) pretty_binds)) <$>
    text "in" <$>
    pretty_body
  where
    n   = length sigs
    ids = [i..(i+n-1)]
    pretty_ids   = map text names
    pretty_sigs  = map (prettyType' p i) sigs
    pretty_defs  = map (prettyExpr' p (i, j + n)) (binds ids)
    pretty_binds = zipWith3 (\pretty_id pretty_sig pretty_def ->
                  pretty_id <+> colon <+> pretty_sig <$> indent 2 (equals <+> pretty_def))
                  pretty_ids pretty_sigs pretty_defs
    pretty_body  = prettyExpr' p (i, j + n) (body ids)

prettyExpr' p (i,j) (Data recflag databinds e) =
  text "data" <+> (pretty recflag) <+> (align .vsep) (map prettyDatabind databinds) <$> prettyExpr' p (i,j) e
    where prettyCtr i' (Constructor ctrName ctrParams) = (text ctrName) <+> (hsep. map (prettyType' p i') $ ctrParams)
          prettyDatabind (DataBind n tvars cons) = hsep (map text $ n:tvars) <+> align
                   (equals <+> intersperseBar (map (prettyCtr (i+ (length tvars)))$ cons [i..(i-1+(length tvars))]) <$$> semi)

prettyExpr' p (i,j) (ConstrOut c es)            = parens $ hsep $ text (constrName c) : map (prettyExpr' p (i,j)) es

prettyExpr' p (i,j) (Case e alts) =
    hang 2 $ text "case" <+> prettyExpr' p (i,j) e <+> text "of" <$> align (intersperseBar (map pretty_alt alts))
    where pretty_alt (ConstrAlt c e1) =
               (text (constrName c) <+> arrow <+> (align $ prettyExpr' p (i, j) e1 ))
          pretty_alt (Default e1) =
               (text "_" <+> arrow <+> (align $ prettyExpr' p (i, j) e1 ))

javaInt :: Type t
javaInt = JClass "java.lang.Integer"


<|start_filename|>testsuite/TypeCheckSpec.hs<|end_filename|>
module TypeCheckSpec where

import Control.Monad (forM_)
import System.Directory
import System.FilePath
import Test.Tasty.Hspec

import Parser (parseExpr, P(..))
import SpecHelper
import TypeCheck (checkExpr)


hasError :: Either a b -> Bool
hasError (Left _)  = True
hasError (Right _) = False


testCasesPath = "testsuite/tests/shouldnt_typecheck"

tcSpec :: Spec
tcSpec = do
  failingCases <- runIO (discoverTestCases testCasesPath)

  curr <- runIO (getCurrentDirectory)
  runIO (setCurrentDirectory $ curr </> testCasesPath)

  describe "Should fail to typecheck" $
    forM_ failingCases
      (\(name, filePath) -> do
         do source <- runIO (readFile filePath)
            it ("should reject " ++ name) $
              let ParseOk parsed = parseExpr source
              in checkExpr parsed >>= ((`shouldSatisfy` hasError)))

  runIO (setCurrentDirectory curr)


<|start_filename|>examples/state_monad/Makefile<|end_filename|>
all : state_monad.sf
	f2j -m apply -m stack -r $^

.PHONY : clean
clean :
	rm -f *.class *.java


<|start_filename|>testsuite/ModuleSpec.hs<|end_filename|>
module ModuleSpec where

import BackEnd
import JavaUtils (getClassPath)
import SpecHelper
import StringPrefixes (namespace)
import TransCFSpec

import Control.Monad (forM_)
import System.Directory
import System.FilePath
import System.IO
import System.Process
import Test.Tasty.Hspec


testCasesPath = "testsuite/tests/should_run/module"

moduleSpec :: Spec
moduleSpec =
  describe "Testing module" $ do
    cases <- runIO (discoverTestCases testCasesPath)

    let compilation = compileN

    curr <- runIO (getCurrentDirectory)
    runIO (setCurrentDirectory $ curr </> testCasesPath)

    cp <- runIO getClassPath
    let p = (proc "java" ["-cp", cp, namespace ++ "FileServer", cp])
              {std_in = CreatePipe, std_out = CreatePipe}
    (Just inP, Just outP, _, proch) <- runIO $ createProcess p
    runIO $ hSetBuffering inP NoBuffering
    runIO $ hSetBuffering outP NoBuffering

    forM_ cases (testConcreteSyn inP outP compilation)

    runIO (setCurrentDirectory curr)


<|start_filename|>frontend/SymbolicEvaluator.hs<|end_filename|>
{- |
Module      :  SymbolicEvaluator
Description :  Symbolic evaluator for Core
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Weixin <<EMAIL>>
Stability   :  experimental
Portability :  portable

-}

module SymbolicEvaluator where

import           Control.Monad.Fix (fix)
import           Data.Maybe
import qualified Language.Java.Syntax as J (Op (..))
import           Prelude hiding (EQ, GT, LT)
import           Text.PrettyPrint.ANSI.Leijen
import           Unsafe.Coerce

import           Panic
import           PrettyUtils
import qualified Src as S
import           SystemFI

instance Show (Type t) where
  show = show . prettyType . unsafeCoerce

instance Show (Expr t e) where
  show = show . prettyExpr . unsafeCoerce

data Value = VInt Integer
           | VBool Bool
           | VConstr S.Name [Value]
           | VFun (Value -> Value)

-- big-step interpreter
eval :: Expr () Value -> Value
eval (Var _ x) = x
eval (Lit x) =
    case x of
      S.Int n -> VInt n
      S.Bool b -> VBool b
      _ -> panic "Lit type unknown"
eval (Lam _ _ f) = VFun (eval . f)
eval (Let _ e f) = eval . f . eval $ e
eval (App e1 e2) =
    case eval e1 of
      VFun f -> f (eval e2)
      _ -> panic "e1 is not a function"
eval (BLam _ f) = eval (f ())
eval (TApp e1 _) = eval e1
eval (If e1 e2 e3) =
       case eval e1 of
         VBool True -> eval e2
         VBool False -> eval e3
         _ -> panic "e1 is not a boolean"
eval (PrimOp e1 op e2) =
       case (eval e1, eval e2) of
         (VInt a, VInt b) ->
             case op of
               -- arithmetic operations
               S.Arith J.Add -> VInt $ a + b
               S.Arith J.Mult -> VInt $ a * b
               S.Arith J.Sub -> VInt $ a - b
               S.Arith J.Div -> VInt $ a `div` b
               -- comparison operations
               S.Compare J.Equal -> VBool $ a == b
               S.Compare J.NotEq -> VBool $ a /= b
               S.Compare J.LThan -> VBool $ a < b
               S.Compare J.LThanE -> VBool $ a <= b
               S.Compare J.GThan -> VBool $ a > b
               S.Compare J.GThanE -> VBool $ a >= b
               -- _ -> simplified
         (VBool a, VBool b) ->
             case op of
               -- logic operations
               S.Logic J.CAnd -> VBool $ a && b
               S.Logic J.COr -> VBool $ a || b
               S.Compare J.Equal -> VBool $ a == b
               S.Compare J.NotEq -> VBool $ a /= b
               _ -> panic $ "Unknown op" ++ show op
         _ -> panic "e1 and e2 should be either Int or Bool simutaneously"
eval g@(Fix _ _ f _ _) = VFun $ eval . f (eval g)
eval (LetRec _ _ binds body) = eval . body . fix $ map eval . binds
eval (Data _ _ e) = eval e
eval (ConstrOut c es) = VConstr (constrName c) (map eval es)
eval (Case e alts) =
    case eval e of
      VConstr n vs -> eval $ fromJust (lookup n table) vs
    where table = map (\(ConstrAlt c _ f) -> (constrName c, f)) alts
eval e = panic $ show e ++ " Can not be evaled"

data SConstructor = SConstructor {sconstrName :: S.Name, sconstrParams :: [SymType], sconstrDatatype :: SymType}

data ExecutionTree = Exp SymValue
                   -- | Fork ExecutionTree SymValue ExecutionTree
                   | Fork SymValue (Either (ExecutionTree, ExecutionTree) [(SConstructor, [S.Name], [ExecutionTree] -> ExecutionTree)])
                   | NewSymVar Int SymType ExecutionTree

data SymType = TInt
             | TBool
             | TFun [SymType] SymType
             | TData S.Name
             | TAny S.Name
               deriving Eq

data SymValue = SVar S.Name Int SymType -- free variables
              | SInt Integer
              | SBool Bool
              | SApp SymValue SymValue
              | SOp Op SymValue SymValue
              | SFun S.Name (ExecutionTree -> ExecutionTree) SymType
              | SConstr SConstructor [SymValue]

data Op = ADD
        | MUL
        | SUB
        | DIV
        | LT
        | LE
        | GT
        | GE
        | EQ
        | NEQ
        | OR
        | AND

-- Add index to SVars and apply symbolic value to top-level closure
exec :: ExecutionTree -> (ExecutionTree, Int)
exec = go 0
    where go i (Exp (SFun n f t)) =
              case go (i+1) (f . Exp $ SVar n i t) of
                (e', i') -> (NewSymVar i t e', i')
          go i e = (e, i)

-- symbolic evaluation
seval :: Expr () ExecutionTree -> ExecutionTree
seval (Var _ x) = x
seval (Lit x) =
    case x of
      S.Int n -> Exp $ SInt n
      S.Bool b -> Exp $ SBool b

seval (If e1 e2 e3) =
    case e1' of
        Exp (SBool True) -> seval e2
        Exp (SBool False) -> seval e3
        _ -> propagate e1' (Left (seval e2, seval e3))
    where e1' = seval e1

seval (PrimOp e1 op e2) =
    case op of
        -- arithmetic operations
        S.Arith J.Add -> merge (SOp ADD, ADD) e1' e2'
        S.Arith J.Mult -> merge (SOp MUL, MUL) e1' e2'
        S.Arith J.Sub -> merge (SOp SUB, SUB) e1' e2'
        S.Arith J.Div -> merge (SOp DIV, DIV) e1' e2'

        -- comparison operations
        S.Compare J.Equal -> merge (SOp EQ, EQ) e1' e2'
        S.Compare J.NotEq -> merge (SOp NEQ, NEQ) e1' e2'
        S.Compare J.LThan -> merge (SOp LT, LT) e1' e2'
        S.Compare J.LThanE -> merge (SOp LE, LE) e1' e2'
        S.Compare J.GThan -> merge (SOp GT, GT) e1' e2'
        S.Compare J.GThanE -> merge (SOp GE, GE) e1' e2'

        -- logic operations
        S.Logic J.CAnd -> merge (SOp AND, AND) e1' e2'
        S.Logic J.COr -> merge (SOp OR, OR) e1' e2'

    where e1' = seval e1
          e2' = seval e2

seval (Lam n t f) = Exp $ SFun n (seval . f) (transType t)
seval (Let _ e f) = seval . f $ seval e
seval (App e1 e2) = treeApply (seval e1) (seval e2)
seval (BLam _ f) =  seval $ f ()
seval (TApp e _) = seval e
seval g@(Fix _ n f t _) = Exp $ SFun n (seval . f (seval g)) (transType t)
seval (LetRec _ _ binds body) = seval . body . fix $ map seval . binds
seval (Data _ _ e) = seval e
seval (ConstrOut c es) = mergeList (SConstr $ transConstructor c) (map seval es)
seval (Case e alts) = propagate (seval e) (Right (map (\(ConstrAlt c ns f) -> (transConstructor c, ns, seval . f)) alts))
seval e = panic $ "seval: " ++ show e

transConstructor :: Constructor () -> SConstructor
transConstructor (Constructor n ts) = SConstructor n (init ts') (last ts')
    where ts' = map transType ts

propagate :: ExecutionTree ->
             Either (ExecutionTree, ExecutionTree) [(SConstructor, [S.Name], [ExecutionTree] -> ExecutionTree)] ->
             ExecutionTree
propagate (Exp e) ts = Fork e ts
propagate (Fork e (Left (l,r))) ts' = Fork e (Left (propagate l ts', propagate r ts'))
propagate (Fork e (Right ts)) ts' = Fork e (Right [(c, ns, \es -> propagate (f es) ts')| (c,ns,f) <- ts])
propagate (NewSymVar i typ t) ts = NewSymVar i typ (propagate t ts)

transType :: Type () -> SymType
transType (JClass t) = jname2symtype t
transType (Fun t1 t2) = TFun [transType t1] (transType t2)
transType (Datatype n _ _) = TData n
transType (TVar n _) = TAny n
transType t = panic $ "transType: " ++ show t

jname2symtype :: String -> SymType
jname2symtype "java.lang.Integer" = TInt
jname2symtype "java.lang.Boolean" = TBool
jname2symtype s = panic $ "str2stype: unsupported java type " ++ s

mergeList :: ([SymValue] -> SymValue) -> [ExecutionTree] -> ExecutionTree
mergeList f [] = Exp (f [])
mergeList f (Exp e : xs) = mergeList (\es -> f (e:es)) xs
mergeList f (Fork e (Left (l, r)) : xs) = Fork e $ Left (mergeList f (l:xs), mergeList f (r:xs))
mergeList f (Fork e (Right ts) : xs) = Fork e $ Right [(c, ns, \es -> mergeList f (g es : xs)) | (c,ns,g) <- ts]
mergeList f (NewSymVar i typ tree : xs) = NewSymVar i typ (mergeList f (tree:xs))

merge :: (SymValue -> SymValue -> SymValue, Op)
      -> ExecutionTree
      -> ExecutionTree
      -> ExecutionTree

merge (_, ADD) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SInt (a+b)
merge (_, ADD) (Exp (SInt 0)) e = e
merge (_, ADD) e (Exp (SInt 0)) = e

merge (_, MUL) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SInt (a*b)
merge (_, MUL) zero@(Exp (SInt 0)) _ = zero
merge (_, MUL) _ zero@(Exp (SInt 0)) = zero
merge (_, MUL) (Exp (SInt 1)) e = e
merge (_, MUL) e (Exp (SInt 1)) = e

merge (_, SUB) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SInt (a-b)
merge (_, SUB) e (Exp (SInt 0)) = e

merge (_, DIV) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SInt (a `div` b)
merge (_, DIV) zero@(Exp (SInt 0)) _ = zero
merge (_, DIV) e (Exp (SInt 1)) = e

merge (_, EQ) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SBool (a==b)
merge (_, EQ) (Exp (SBool a)) (Exp (SBool b)) = Exp $ SBool (a==b)

merge (_, NEQ) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SBool (a/=b)
merge (_, NEQ) (Exp (SBool a)) (Exp (SBool b)) = Exp $ SBool (a/=b)

merge (_, LT) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SBool (a<b)
merge (_, LE) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SBool (a<=b)
merge (_, GT) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SBool (a>b)
merge (_, GE) (Exp (SInt a)) (Exp (SInt b)) = Exp $ SBool (a>=b)

merge (_, OR) (Exp (SBool a)) (Exp (SBool b)) = Exp $ SBool (a||b)
merge (_, OR) true@(Exp (SBool True)) _ = true
merge (_, OR) _ true@(Exp (SBool True)) = true
merge (_, OR) e (Exp (SBool False)) = e
merge (_, OR) (Exp (SBool False)) e = e

merge (_, AND) (Exp (SBool a)) (Exp (SBool b)) = Exp $ SBool (a&&b)
merge (_, AND) false@(Exp (SBool False)) _ = false
merge (_, AND) _ false@(Exp (SBool False)) = false
merge (_, AND) (Exp (SBool True)) e = e
merge (_, AND) e (Exp (SBool True)) = e

merge (f, _) (Exp e1) (Exp e2) = Exp (f e1 e2)
merge f (Fork e (Left (l,r))) t = Fork e $ Left (merge f l t, merge f r t)
merge f t (Fork e (Left (l,r))) = Fork e $ Left (merge f t l, merge f t r)
merge f (Fork e (Right ts)) t = Fork e $ Right [(c, ns, \es -> merge f (g es) t) | (c,ns,g) <- ts]
merge f t (Fork e (Right ts)) = Fork e $ Right [(c, ns, merge f t . g) | (c,ns,g) <- ts]
merge f (NewSymVar i t t1) t2 = NewSymVar i t (merge f t1 t2)
merge f t1 (NewSymVar i typ t2) = NewSymVar i typ (merge f t1 t2)


treeApply :: ExecutionTree -> ExecutionTree -> ExecutionTree
treeApply (Exp e) t =
    case e of
      SVar n i typ -> apply (SApp (SVar n i typ)) t
      SFun _ f _ -> f t
treeApply (Fork e (Left (l,r))) t = Fork e $ Left (treeApply l t, treeApply r t)
treeApply (Fork e (Right ts)) t = Fork e $ Right [(c, ns, \es -> treeApply (f es) t) | (c,ns,f) <- ts]
treeApply (NewSymVar i typ t1) t2 = NewSymVar i typ (treeApply t1 t2)

apply :: (SymValue -> SymValue) -> ExecutionTree -> ExecutionTree
apply f (Exp e) = Exp (f e)
apply f (Fork e (Left (l,r))) = Fork e $ Left (apply f l, apply f r)
apply f (Fork e (Right ts)) = Fork e $ Right [(c, ns, apply f . g)| (c,ns,g) <- ts]
apply f (NewSymVar i typ t) = NewSymVar i typ (apply f t)

instance Pretty Value where
    pretty (VFun _) = text "<<func>>"
    pretty (VInt x) = integer x
    pretty (VBool b) = bool b
    pretty (VConstr n vs) = fillSep $ text n : map pretty vs

instance Pretty Op where
    pretty op =
        text $ case op of
                 ADD -> "+"
                 MUL -> "*"
                 SUB -> "-"
                 DIV -> "/"
                 LT -> "<"
                 LE -> "<="
                 GT -> ">"
                 GE -> ">="
                 EQ -> "=="
                 NEQ -> "/="
                 OR -> "||"
                 AND -> "&&"

instance Pretty SymValue where
    -- pretty (SVar n i _) = text n <> int i
    pretty (SVar _ i _) = text "x" <> int i
    -- pretty (SVar n _ _) = text n
    pretty (SInt i) = integer i
    pretty (SBool b) = bool b
    pretty (SApp e1 e2) = pretty e1 <+> pretty e2
    pretty (SOp op e1 e2) = parens $ pretty e1 <+> pretty op <+> pretty e2
    pretty (SFun{}) = text "<<fun>>"
    pretty (SConstr c es) = parens $ hsep $ text (sconstrName c) : map pretty es

instance Pretty ExecutionTree where
    pretty t = fst $ prettyTree t (text "True") 5

prettyTree :: ExecutionTree -> Doc -> Int -> (Doc, Int)
prettyTree _ _ 0 = (empty, 0)
prettyTree (Exp e) s stop = (s <+> evalTo <+> pretty e <> linebreak, stop - 1)
prettyTree (Fork e (Left (l,r))) s stop =
    let s1 = pretty e
        (s2, stop2) = prettyTree l (s <+> text "&&" <+> s1) stop
        (s3, stop3) = prettyTree r (s <+> text "&&" <+> prependNot s1) stop2
    in (s2 <> s3, stop3)
prettyTree (Fork e (Right ts)) s stop =
    foldl (\(sacc, i) (c,ns,f) ->
               let (snew, i') = prettyTree (f $ supply ns [1..]) (s <+> text "&&" <+> pretty e <+> equals <+> hsep (map text $ sconstrName c : ns)) i
               in (sacc <> snew, i'))
       (empty, stop)
       ts
prettyTree (NewSymVar _ _ t) s stop = prettyTree t s stop

supply :: [S.Name] -> [Int] -> [ExecutionTree]
supply ns ids = zipWith (\i n -> Exp $ SVar n i TInt) ids ns

-- genVars n = map (text . ("x"++) . show) [1..n]

fun e = fst . exec . seval $ e


<|start_filename|>testsuite/SpecHelper.hs<|end_filename|>
module SpecHelper
  (discoverTestCases
  ,parseExpectedOutput
  ) where

import System.Directory (getDirectoryContents)
import System.FilePath  (dropExtension)

import Data.Char (isSpace)
import Data.List (isSuffixOf)

type Name   = String
type Source = String
type ExpectedOutput = String

discoverTestCases :: FilePath -> IO [(Name, FilePath)]
discoverTestCases directory =
  do fileNames <- filter (isSuffixOf ".sf") <$> getDirectoryContents directory
     return (map (\f -> (dropExtension f, f)) fileNames)

parseExpectedOutput :: Source -> Maybe ExpectedOutput
parseExpectedOutput source =
  let firstLine = takeWhile (/= '\n') source in
  case firstLine of
    '-':'-':'>':_ -> Just (strip (drop 3 firstLine))
    _             -> Nothing

strip :: String -> String
strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace


<|start_filename|>backend/archive/BaseTransCFJavaNew.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts, TypeOperators, MultiParamTypeClasses, ScopedTypeVariables #-}
{- |
Module      :  BaseTransCFJavaNew
Description :  Basic translation of dependently typed FCore to Java
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Tomas <<EMAIL>>
Stability   :  stable
Portability :  non-portable (MPTC)

This module implements the basic translation of FCore to Java. For
more information, please refer to the paper on wiki.
-}


module BaseTransCFJavaNew where

import qualified Language.Java.Syntax as J
import           Lens.Micro

import           ClosureFNew
import           Inheritance
import           JavaEDSL
import           MonadLib hiding (Alt)
import           Panic
import qualified Src as S
import           StringPrefixes

instance (:<) (Translate m) (Translate m) where
   up = id

type InitVars = [J.BlockStmt]

createCUB :: Maybe J.PackageDecl -> [J.TypeDecl] -> J.CompilationUnit
createCUB package compDef = cu
  where
    cu = J.CompilationUnit package [] compDef


initClass :: String -> String -> J.Exp -> J.BlockStmt
initClass className tempName expr =
  let ty = classTy className
  in localFinalVar ty
       (varDecl tempName
          (if ty == objClassTy
             then expr
             else cast ty expr))

type Var = Int -- Either normal variable or class name

type TransJavaExp = Either J.Name J.Literal -- either variable or special case: Lit

type TransType = ([J.BlockStmt], TransJavaExp, Type TransBind)

data TyBind = TB { unTB :: Type (Var, TyBind) }
            | None

type TransBind = (Var, TyBind)

data Translate m =
       T
         { translateM :: Expr TransBind -> m TransType
         , translateScopeM :: Scope TransBind -> Maybe Int -> m ([J.BlockStmt], TransJavaExp, Scope TransBind)
         , translateApply :: Bool -> m TransType -> Expr TransBind -> m TransType
         , translateIf :: m TransType -> m TransType -> m TransType -> m TransType
         , translateLet :: TransType -> (TransBind -> Expr TransBind) -> m TransType
         , translateScopeTyp :: Int -> Int -> [J.BlockStmt] -> Scope TransBind -> m ([J.BlockStmt], TransJavaExp, Scope TransBind) -> String -> m ([J.BlockStmt], Scope TransBind)
         , genApply :: J.Exp -> Scope TransBind -> String -> J.Type -> J.Type -> m [J.BlockStmt]
         , genRes :: Scope TransBind -> [J.BlockStmt] -> m [J.BlockStmt]
         , applyRetType :: Type TransBind -> m (Maybe J.Type)
         , genClone :: m Bool
         , withApply :: m Bool
         , getPrefix :: m String
         , javaType :: Type TransBind -> m J.Type
         , chooseCastBox :: Type TransBind -> m (String -> J.Exp -> J.BlockStmt, J.Type)
         , stackMainBody :: Type Int -> m [J.BlockStmt]
         , genClosureVar :: Bool -> Int -> TransJavaExp -> m J.Exp
         , createWrap :: String -> Expr TransBind -> m (J.CompilationUnit, Type TransBind)
         }

getNewVarName :: MonadState Int m => Translate m -> m String
getNewVarName _ = do
  (n :: Int) <- get
  put (n + 1)
  return $ localvarstr ++ show n

assignVar :: Monad m => Translate m -> Type TransBind -> String -> J.Exp -> m J.BlockStmt
assignVar this t varId e = do
  aType <- javaType this t
  return $
    localFinalVar aType (varDecl varId e)

getTupleClassName :: [a] -> String
getTupleClassName tuple =
  if lengthOfTuple > 50
    then panic "The length of tuple is too long (>50)!"
    else namespace ++ "tuples.Tuple" ++ show lengthOfTuple
  where
    lengthOfTuple = length tuple

genIfBody :: MonadState Int m
          => Translate m
          -> m TransType
          -> m TransType
          -> ([J.BlockStmt], TransJavaExp)
          -> Int
          -> m TransType
genIfBody this m2 m3 (s1, j1) n = do
  (s2, j2, t2) <- m2
  (s3, j3, _) <- m3
  let ifvarname = ifresultstr ++ show n
  aType <- javaType this t2
  let ifresdecl = localVar aType (varDeclNoInit ifvarname)
  let thenPart = J.StmtBlock $ block (s2 ++ [bsAssign (name [ifvarname]) (unwrap j2)])
  let elsePart = J.StmtBlock $ block (s3 ++ [bsAssign (name [ifvarname]) (unwrap j3)])
  let ifstmt = bStmt $ J.IfThenElse (unwrap j1) thenPart elsePart
  return (s1 ++ [ifresdecl, ifstmt], var ifvarname, t2)

getS3 :: MonadState Int m
      => Translate m
      -> J.Exp
      -> J.Exp
      -> Scope TransBind
      -> J.Type
      -> m ([J.BlockStmt], TransJavaExp)
getS3 this j1 j2 retTyp ctempCastTyp = do
  (n :: Int) <- get
  put (n + 2)
  let f = localvarstr ++ show n
  let xf = localvarstr ++ show (n + 1)
  let fexp = left . var $ f
  let fd = localVar ctempCastTyp (varDecl f j1)
  let fs = assignField (fieldAccExp fexp closureInput) j2
  (castBox, typ) <- chooseCastBox this (scope2ctyp retTyp)
  apply <- genApply this fexp retTyp xf typ ctempCastTyp
  let fout = fieldAccess fexp closureOutput
  res <- genRes this retTyp [castBox xf fout]
  let r = fd : fs : apply ++ res
  return (r, var xf)


createTypeHouse :: MonadState Int m
                => Translate m
                -> String
                -> m ([J.BlockStmt], TransJavaExp)
createTypeHouse this str = do
  (n :: Int) <- get
  put (n + 1)
  let typeVar = localvarstr ++ show n
  let fstmt = [ localVar typeOfType (varDecl typeVar typeHouseCreate)
              , assignField (fieldAccExp (left . var $ typeVar) typeField) (J.Lit (J.String str))
              ]
  return (fstmt, var typeVar)

substEScope :: Int -> Expr TransBind -> Scope TransBind -> Scope TransBind
substEScope n t (Body t1) = Body (substExpr n t t1)
substEScope n t (Type t1 f) = Type (substExpr n t t1) (substEScope n t . f)

substExpr :: Int -> Expr TransBind -> Expr TransBind -> Expr TransBind
substExpr n t v@(Var _ (x, _)) = if n == x then t else v
substExpr n t (Pi n' s) = Pi n' (substEScope n t s)
substExpr _ _ x = x

-- | Translation dispatcher
trans :: (MonadState Int m, selfType :< Translate m) => Base selfType (Translate m)
trans self =
  let this = up self
  in T
    { translateM = translateM' this
    , translateScopeM = translateScopeM' this
    , translateApply = translateApply' this
    , translateIf = translateIf' this
    , translateLet = translateLet' this
    , translateScopeTyp = translateScopeTyp' this
    , genApply = \f _ _ _ _ -> return [bStmt $ applyMethodCall f]
    , genRes = const return
    , applyRetType = applyRetType' this
    , genClone = return False -- do not generate clone method
    , withApply = return True
    , getPrefix = return namespace
    , javaType = javaType' this
    , chooseCastBox = chooseCastBox' this
    , stackMainBody = \_ -> return []
    , genClosureVar = \_ _ j1 -> return (unwrap j1)
    , createWrap = createWrap' this
    }

-- Field functions

translateM' this e =
  case e of
    Var _ (i, t) -> return ([], var (localvarstr ++ show i), unTB t)

    Lit lit ->
      case lit of
        (S.Int i)    -> return ([], Right $ J.Int i, JClass "java.lang.Integer")
        (S.UnitLit)  -> return ([], Right J.Null, Unit)
        (S.String s) -> return ([], Right $ J.String s, JClass "java.lang.String")
        (S.Bool b)   -> return ([], Right $ J.Boolean b, JClass "java.lang.Boolean")
        (S.Char c)   -> return ([], Right $ J.Char c, JClass "java.lang.Character")

    PrimOp e1 op e2 -> do
      (s1, j1, _) <- translateM this e1
      (s2, j2, _) <- translateM this e2
      let j1' = unwrap j1
      let j2' = unwrap j2
      let (jexpr, typ) =
            case op of
              (S.Arith realOp)   -> (J.BinOp j1' realOp j2', JClass "java.lang.Integer")
              (S.Compare realOp) -> (J.BinOp j1' realOp j2', JClass "java.lang.Boolean")
              (S.Logic realOp)   -> (J.BinOp j1' realOp j2', JClass "java.lang.Boolean")
      newVarName <- getNewVarName this
      assignExpr <- assignVar this typ newVarName jexpr
      return (s1 ++ s2 ++ [assignExpr], var newVarName, typ)

    If e1 e2 e3 -> translateIf this (translateM this e1) (translateM this e2) (translateM this e3)

    Tuple tuple ->
      case tuple of
        [t] -> do
          (s1, j1, t1) <- translateM this t
          return (s1, j1, TupleType [t1])
        _ -> do
          tuple' <- mapM (translateM this) tuple
          let (statements, exprs, types) = unzip3 tuple' & _1 %~ concat
          newVarName <- getNewVarName this
          let c = getTupleClassName tuple
          let rhs = instCreat (classTyp c) (map unwrap exprs)
          assignExpr <- assignVar this (JClass c) newVarName rhs
          return (statements ++ [assignExpr], var newVarName, TupleType types)

    Proj index expr -> do
      ret@(statement, javaExpr, exprType) <- translateM this expr
      case exprType of
        TupleType [_] -> return ret
        TupleType types -> do
          newVarName <- getNewVarName this
          let typ = types !! (index - 1)
          aType <- javaType this typ
          let rhs = cast aType (fieldAccess (unwrap javaExpr) ("_" ++ show index))
          assignExpr <- assignVar this typ newVarName rhs
          return (statement ++ [assignExpr], var newVarName, typ)
        _ -> panic "BaseTransCFJava.trans: expected tuple type"

    App e1 e2 -> translateApply this False (translateM this e1) e2

    Let _ expr body -> do
      (s1, j1, t1) <- translateM this expr
      translateLet this (s1, j1, t1) body

    Lam _ se -> do
      (s, je, t) <- translateScopeM this se Nothing
      return (s, je, Pi "_" t)

    Mu _ (Type t se) -> do
      n <- get
      put (n + 1)
      (expr, je, _) <- translateScopeM this (se (n, TB t)) (Just n)
      return (expr, je, t)

    SeqExprs es -> do
      es' <- mapM (translateM this) es
      let (_, lastExp, lastType) = last es'
      let statements = concatMap (\(x, _, _) -> x) es'
      return (statements, lastExp, lastType)

    JNew c args -> do
      args' <- mapM (translateM this) args
      let (statements, exprs, types) = unzip3 args' & _1 %~ concat
      let rhs = J.InstanceCreation
                  (map
                     (\y -> case y of
                        JClass x -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident x, [])]
                        _        -> sorry "BaseTransCFJava.trans.JNew: no idea how to do")
                     types)
                  (J.ClassType [(J.Ident c, [])])
                  (map unwrap exprs)
                  Nothing
      let typ = JClass c
      newVarName <- getNewVarName this
      assignExpr <- assignVar this typ newVarName rhs
      return (statements ++ [assignExpr], var newVarName, typ)

    JMethod c m args r -> do
      args' <- mapM (translateM this) args
      let (statements, exprs, types) = unzip3 args' & _1 %~ concat
      let exprs' = map unwrap exprs
      let refTypes =
            map
              (\y -> case y of
                 JClass x -> J.ClassRefType $ J.ClassType [(J.Ident x, [])]
                 _        -> sorry "BaseTransCFJava.trans.JMethod: no idea how to do")
              types
      (classStatement, rhs) <- case c of
                                 Right ce ->
                                   do
                                     (classS, classE, _) <- translateM this ce
                                     return
                                       (classS, J.MethodInv $ J.PrimaryMethodCall
                                                                (unwrap classE)
                                                                refTypes
                                                                (J.Ident m)
                                                                exprs')
                                 Left cn ->
                                   return
                                     ([], J.MethodInv $ J.TypeMethodCall
                                                          (J.Name [J.Ident cn])
                                                          refTypes
                                                          (J.Ident m)
                                                          exprs')
      if r /= "java.lang.Void"
        then do
          let typ = JClass r
          newVarName <- getNewVarName this
          assignExpr <- assignVar this typ newVarName rhs
          return (statements ++ classStatement ++ [assignExpr], var newVarName, typ)
        else return
               (statements ++ classStatement ++ [J.BlockStmt $ J.ExpStmt rhs], Right J.Null, Unit)

    JField c fName r -> do
      (classStatement, classExpr, _) <- case c of
                                          Right ce ->
                                            translateM this ce
                                          Left cn ->
                                            return ([], Left $ J.Name [J.Ident cn], undefined)
      newVarName <- getNewVarName this
      aType <- javaType this r
      let rhs = J.Cast aType $ J.FieldAccess $ J.PrimaryFieldAccess (unwrap classExpr)
                                                 (J.Ident fName)
          assignExpr = localFinalVar aType $ varDecl newVarName rhs
      return (classStatement ++ [assignExpr], var newVarName, r)


    CastUp t e -> do
      (s, v, _) <- translateM this e
      return (s, v, t)

    CastDown t e -> do
      (s, v, _) <- translateM this e
      return (s, v, t)

    JClass className -> do
      (stmts, jvar) <- createTypeHouse this className
      return (stmts, jvar, Star)

    Star -> do
      (stmts, jvar) <- createTypeHouse this "Star"
      return (stmts, jvar, Star)

    TupleType xs -> do
      (stmts, jvar) <- createTypeHouse this "TupleType"
      return (stmts, jvar, Star)

    Unit -> do
      (stmts, jvar) <- createTypeHouse this "Unit"
      return (stmts, jvar, Star)

    Pi _ s -> do
      (stmts, jvar) <- createTypeHouse this "Pi"
      return (stmts, jvar, Star)

    -- Error related
    _ -> panic "BaseTransCFJavaNew.trans: don't know how to do"

translateScopeM' this e m =
  case e of
    Body t -> do
      (s, je, t1) <- translateM this t
      return (s, je, Body t1)
    Type t g -> do
      n <- get
      let (x1, x2) = maybe (n + 1, n + 2) (\i -> (i, n + 1)) m
      put (x2 + 1)
      let nextInClosure = g (x2, TB t)
      typT1 <- javaType this t
      let flag = typT1 == objClassTy
      let accessField = fieldAccess (left $ var (localvarstr ++ show x1)) closureInput
      let xf = localFinalVar typT1
                 (varDecl (localvarstr ++ show x2)
                    (if flag
                       then accessField
                       else cast typT1 accessField))
      closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
      (cvar, t1) <- translateScopeTyp
                      this
                      x1
                      n
                      [xf]
                      nextInClosure
                      (translateScopeM this nextInClosure Nothing)
                      closureClass
      let fstmt = [localVar closureType (varDecl (localvarstr ++ show n) (funInstCreate n))]
      return
        (cvar ++ fstmt, var (localvarstr ++ show n), Type t (\a -> substEScope x2 (Var "_" a) t1))

translateApply' this flag m1 m2 = do
  (s1, j1', Pi _ (Type t1 g)) <- m1
  (n :: Int) <- get
  put (n + 1)
  (s2, j2, _) <- translateM this m2
  let retTyp = substEScope n m2 (g (n, None))
  j1 <- genClosureVar this flag (getArity retTyp) j1'
  (s3, nje3) <- getS3 this j1 (unwrap j2) retTyp closureType
  return (s2 ++ s1 ++ s3, nje3, scope2ctyp retTyp)

-- TODO: This is not dependently typed
translateLet' this (s1, j1, t1) body = do
  (n :: Int) <- get
  put (n + 1)
  (s2, j2, t2) <- translateM this (body (n, TB t1))
  let x = localvarstr ++ show n
  jt1 <- javaType this t1
  let xDecl = localVar jt1 (varDecl x $ unwrap j1)
  return (s1 ++ [xDecl] ++ s2, j2, t2)

translateIf' this m1 m2 m3 = do
  n <- get
  put (n + 1)
  (s1, j1, _) <- m1
  genIfBody this m2 m3 (s1, j1) n

translateScopeTyp' this x1 f initVars _ otherStmts closureClass = do
  b <- genClone this
  (ostmts, oexpr, t1) <- otherStmts
  let fc = f
  return
    ([ localClassDecl (closureTransName ++ show fc) closureClass
         (closureBodyGen
            [ memberDecl $ fieldDecl (classTy closureClass)
                             (varDecl (localvarstr ++ show x1) J.This)
            ]
            (initVars ++ ostmts ++ [bsAssign (name [closureOutput]) (unwrap oexpr)])
            fc
            b
            (classTy closureClass))
     ], t1)

javaType' this typ =
  case typ of
    (JClass c) -> return $ classTy c
    (Pi _ s) -> do
      closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
      return (classTy closureClass)
    (TupleType tuple) ->
      case tuple of
        [t] -> javaType this t
        _   -> return $ classTy $ getTupleClassName tuple
    _ -> return objClassTy

chooseCastBox' this typ =
  case typ of
    (JClass c) -> return (initClass c, classTy c)
    (Pi _ _) -> do
      closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
      return (initClass closureClass, classTy closureClass)
    (TupleType tuple) ->
      case tuple of
        [t] -> chooseCastBox this t
        _ -> do
          let tupleClassName = getTupleClassName tuple
          return (initClass tupleClassName, classTy tupleClassName)
    _ -> return (initClass "Object", objClassTy)

createWrap' this name expr = do
  (bs, e, t) <- translateM this expr
  returnType <- applyRetType this t
  let javaCode =
        let returnStmt = [bStmt $ J.Return $ Just (unwrap e)]
        in wrapperClass False name (bs ++ returnStmt) returnType mainBody
  return (createCUB Nothing [javaCode], t)

applyRetType' _ t =
  case t of
    JClass "java.lang.Integer" -> return $ Just $ J.PrimType J.IntT
    JClass "java.lang.Boolean" -> return $ Just $ J.PrimType J.BooleanT
    _                          -> return $ Just objClassTy


<|start_filename|>examples/case_studies/SearchLinkedList.hs<|end_filename|>
{-# LANGUAGE TemplateHaskell #-}

module SearchLinkedList where

-- 1 try "runTests" to test all the properties
-- 2 try "mulitTest" to test "prop_pseudo_goal" 10 times with time showed below

import Test.QuickCheck.All
import Test.QuickCheck
import Data.List
import Text.Printf
import System.CPUTime
import System.Timeout


--function "contains"
contains :: [Int] -> Int -> Bool
contains [] e = False
contains (x:xs) e = x == e || contains xs e

--function "firstZero"
firstZero :: [Int] -> Int
firstZero [] = 0
firstZero (x:xs) = if x == 0 then 0
                             else (firstZero xs) + 1


--function "firstZeroAtPos"
firstZeroAtPos :: [Int] -> Int -> Bool
firstZeroAtPos [] e = False
firstZeroAtPos (x:xs) e = if e ==0 then x == 0
                                   else x /= 0 &&
                                        firstZeroAtPos xs (e-1)

----Property "goal"
prop_goal :: [Int] -> Int -> Bool
prop_goal l i = if (firstZero l) == i
                then if contains l 0
                     then firstZeroAtPos l i
                     else i == length l
                else True

---prop pseudo goal
prop_pseudo_goal :: [Int] -> Int -> Bool
prop_pseudo_goal l i = if (firstZero l) == i
                     then if contains l 10
                     then firstZeroAtPos l i
                     else i == length l
                    else True



----timer
timeIt :: (Fractional c) => (a -> IO b) -> a -> IO c
timeIt action arg = do
       startTime <- getCPUTime
       action arg
       finishTime <- getCPUTime
       return $ fromIntegral (finishTime - startTime) / 1000000000

--timeIt' :: (Fractional c) => (a -> b) -> a -> IO c
--timeIt' f = timeIt (\x -> f x `seq` return())

oneTest = timeout 1000000 $ timeIt quickCheck prop_pseudo_goal >>= print

multiTest = do
            startTime <- getCPUTime
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000





------for-quickCheck-test------
return []                    --
runTests = $quickCheckAll    --
-------------------------------







<|start_filename|>runtime/src/f2j/tuples/Tuple2.java<|end_filename|>
package f2j.tuples;

public class Tuple2 {
  public final Object _1, _2;

  public Tuple2(Object _1, Object _2) {
    this._1 = _1;
    this._2 = _2;
  }
}


<|start_filename|>compiler/Main.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts
           , FlexibleInstances
           , MultiParamTypeClasses
           , RankNTypes
           , RecordWildCards
           #-}
{- |
Module      :  Main
Description :  Main module for f2j.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>, Jeremy <<EMAIL>>
Stability   :  experimental
Portability :  non-portable (MPTC)
-}

module Main where

-- import           Assertions () -- Import this just to run static assertions at compile time.

import           BackEnd
import           FrontEnd (source2core)
import           JavaUtils
import           MonadLib

import           Data.Char (toLower)
import           Data.List (intercalate)
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
import           Options.Applicative
import           System.Environment (getArgs, withArgs)
import           System.FilePath (takeBaseName)
import           System.IO


data Options = Options
    { optCompile       :: Bool
    , optCompileAndRun :: Bool
    , optDump          :: DumpOption
    , optVerbose       :: Bool
    , optSilent        :: Bool
    , optInline        :: Bool
    , optTransMethod   :: [TransMethod]
    , optSourceFiles   :: [String]
    } deriving (Eq, Show)

data TransMethod = Apply
                 | Naive
                 | Stack
                 | NewCore
                 -- | Unbox
                 -- | StackAU1
                 -- | StackAU2
                 -- | BenchN
                 -- | BenchS
                 -- | BenchNA
                 -- | BenchSA
                 -- | BenchSAI1
                 -- | BenchSAI2
                 deriving (Eq, Show, Ord)

transOpts = Map.fromList [("apply", Apply), ("naive", Naive), ("stack", Stack), ("newcore", NewCore)]

dumpOpts = Map.fromList
             [ ("parsed", Parsed)
             , ("tchecked", TChecked)
             , ("systemfi", SystemFI)
             , ("core", SimpleCore)
             , ("closuref", ClosureF)
             ]

intersperseComma :: Map.Map String a -> String
intersperseComma m = intercalate ", " (Map.keys m)

parseOpts :: Map.Map String a -> String -> ReadM a
parseOpts opts str =
  let parsed = Map.lookup (map toLower str) opts
  in case parsed of
    Just p  -> return p
    Nothing -> readerError $ "expected one of: " ++ intersperseComma opts

options :: Parser Options
options = Options <$> switch (long "compile" <> short 'c' <> help "Compile Java source")
                  <*> switch (long "run" <> short 'r' <> help "Compile & run Java source")
                  <*> option (str >>= parseOpts dumpOpts)
                        (long "dump" <>
                         value NoDump <>
                         short 'd' <>
                         metavar "TYPE" <>
                         completeWith (Map.keys dumpOpts) <>
                         help ("Dump option. Can be either " ++ intersperseComma dumpOpts))
                  <*> switch (long "verbose" <> short 'v' <> help "Whether to be verbose")
                  <*> switch (long "silent" <> help "Whether to keep silent")
                  <*> switch (long "inline" <> short 'i' <> help "Inline your program")
                  <*> many
                        (option (str >>= parseOpts transOpts)
                           (long "method" <>
                            short 'm' <>
                            metavar "METHOD" <>
                            completeWith (Map.keys transOpts) <>
                            help
                              ("Translation method. Can be either " ++ intersperseComma transOpts)))
                  <*> some (argument str (metavar "FILES..." <> action "file"))

getOpts :: IO Options
getOpts = execParser opts
  where
    opts = info (helper <*> options) (fullDesc <> header "f2j - SystemF to Java compiler")


main :: IO ()
main = do
  rawArgs <- getArgs
  -- If the user did not specify any arguments, pretend as "--help" was given
  Options{..} <- (if null rawArgs then withArgs ["--help"] else id) getOpts

  forM_ optSourceFiles (\source_path ->
    do let output_path      = inferOutputPath source_path
           translate_method = optTransMethod
           method = Set.insert Naive (Set.fromList translate_method)
       let opts = getOpt method

       unless optSilent $
         do putStrLn (takeBaseName source_path ++ " using " ++ (show . Set.toList $ method))
            putStrLn ("Compiling to Java source code ( " ++ output_path ++ " )")

       source     <- readFile source_path
       coreExpr   <- source2core optDump (source_path, source)
       javaSource <- if translate_method == [NewCore]
                     then picore2java optDump compileN2 (inferClassName output_path) coreExpr
                     else core2java False optInline optDump opts (inferClassName output_path) coreExpr
       writeFile output_path javaSource

       when (optCompile || optCompileAndRun) $
         do when optVerbose $ putStrLn "  Compiling to Java bytecode"
            compileJava output_path
       when optCompileAndRun $
         do when optVerbose $ do { putStr "  Running Java\n  Output: "; hFlush stdout }
            runJava output_path)

getOpt :: Set.Set TransMethod -> Compilation
getOpt translate_method
       | translate_method == Set.fromList [Apply, Naive] = compileAO
       | translate_method == Set.fromList [Apply, Naive, Stack] = compileS
       | translate_method == Set.fromList [Naive, Stack] = compileSN
       | otherwise = compileN


<|start_filename|>backend/BenchGenCF2J.hs<|end_filename|>
{-# OPTIONS -XRankNTypes -XFlexibleInstances -XFlexibleContexts -XTypeOperators -XMultiParamTypeClasses  -XScopedTypeVariables -XKindSignatures -XUndecidableInstances -XOverlappingInstances #-}

module BenchGenCF2J where

import Prelude hiding (init, last)

import qualified Language.Java.Syntax as J
import Inheritance
--import qualified Data.Map as Map
import qualified Data.Set as Set
import ClosureF
import BaseTransCFJava
-- import StringPrefixes
import MonadLib
-- import Control.Monad
import JavaEDSL




-- Closure c0 = (Closure) apply();
closureInit id = (J.LocalVars []  closureType--type
         [J.VarDecl (J.VarId (J.Ident id)) -- name
                (Just $ J.InitExp $ (J.Cast closureType) (J.MethodInv $ J.MethodCall (J.Name [(J.Ident "apply")]) []))]) -- init

fieldAcc classId fieldId = (J.PrimaryFieldAccess (J.ExpName (J.Name [(J.Ident classId)])) (J.Ident fieldId))

-- Closure c1 = (Closure) c0.out;
closurePass idl idr = (J.LocalVars [] closureType --type
         [J.VarDecl (J.VarId (J.Ident idl)) -- name
                (Just $ J.InitExp $ (J.Cast closureType) (J.FieldAccess $ (fieldAcc idr "out")))]) -- init

-- c1.x = x;
paraAssign classId paraId = (J.BlockStmt $ J.ExpStmt $ J.Assign (J.FieldLhs $ (fieldAcc classId "x")) (J.EqualA) (J.ExpName $ J.Name [(J.Ident paraId)]))

-- c1.apply();
invokeApply classId = (J.BlockStmt $ J.ExpStmt $ J.MethodInv $ (J.PrimaryMethodCall (J.ExpName $ (J.Name [J.Ident classId])) [] (J.Ident "apply") []))

-- return (Integer) c2.out;
retRes returnType classId = (J.BlockStmt (J.Return $ Just (J.Cast (classTy returnType) (J.FieldAccess (fieldAcc classId "out")))))

testfuncArgType :: [String] -> State Int [J.FormalParam]
testfuncArgType [] = return []
testfuncArgType (x:xs) = case x of
                          "Integer" -> do
                            (n::Int) <- get
                            put (n+1)
                            r <- testfuncArgType xs
                            return $ (J.FormalParam [] (J.PrimType J.IntT) False (J.VarId (J.Ident $ ("x" ++ show n)))) : r
                          a -> do
                            (n :: Int) <- get
                            put (n+1)
                            r <- testfuncArgType xs
                            return $ ((J.FormalParam []) (J.RefType $ J.ClassRefType $ J.ClassType [((J.Ident a), [])]) False (J.VarId $ (J.Ident $ "x" ++ show n))) : r

testfuncBody paraType =
        case paraType of
                [] -> []
                x : [] -> [ closureInit c0, paraAssign c0 x0, invokeApply c0, retRes "Integer" c0]
                                where
                                        c0 = "c0"
                                        x0 = "x0"

                x : y : [] ->
                        [ closureInit c0,
                          paraAssign  c0 x0 ,
                          invokeApply c0,
                          closurePass c1 c0,
                          paraAssign c1 x1,
                          invokeApply c1,
                          retRes "Integer" c1]
                        where
                                c0 = "c0"
                                x0 = "x0"
                                c1 = "c1"
                                x1 = "x1"
                _ -> []


-- TODO: fix name confict
genParams :: [String] -> [J.FormalParam]
genParams paraType = let (lst, _) = runState (testfuncArgType paraType) 0
                     in lst

getClassDecl className bs ass paraType testfuncBody returnType mainbodyDef = J.ClassTypeDecl (J.ClassDecl [J.Public] (J.Ident className) [] (Nothing) []
        (J.ClassBody [J.MemberDecl $ methodDecl [J.Static] returnType "apply" [] body,
          J.MemberDecl $ methodDecl [J.Public, J.Static] returnType "test" (genParams paraType) (Just (J.Block (testfuncBody paraType))),
      J.MemberDecl $ methodDecl [J.Public, J.Static] Nothing "main" mainArgType mainbodyDef]))
    where
        body = Just (J.Block (bs ++ ass))

getParaType :: (Type t) -> [String]
getParaType tp = case tp of
                  Forall a -> getScopeType a 0
                  _ -> []

-- (Scope b t e) -> [Int]
getScopeType :: TScope t  -> Int -> [String]
getScopeType (Kind f) n = []
getScopeType (Type (TVar i) f) n = "Integer" : (getScopeType (f ()) 0)
getScopeType (Type CFInt f) n = "java.lang.Integer" : (getScopeType (f ()) 0)
getScopeType (Type CFInteger f) n = "java.lang.Integer" : (getScopeType (f ()) 0)
getScopeType (Type (JClass s) f) n = s : (getScopeType (f ()) 0)
getScopeType _ _= []

benchmarkPackage name = Just (J.PackageDecl (J.Name [(J.Ident name)]))

createCUB this compDef = cu where
   cu = J.CompilationUnit (benchmarkPackage "benchmark") [] (compDef)
--[closureClass this] ++

-- data type for naive BenchGen
data BenchGenTranslate m = TB {
  toTB :: Translate m -- supertype is a subtype of Translate (later on at least)
}

instance (:<) (BenchGenTranslate m) (Translate m) where
   up = up . toTB

instance (:<) (BenchGenTranslate m) (BenchGenTranslate m) where -- reflexivity
  up = id


transBench :: (MonadState Int m, selfType :< BenchGenTranslate m, selfType :< Translate m) => Mixin selfType (Translate m) (BenchGenTranslate m)
transBench this super = TB {
  toTB = super {
  -- here, I guess, you will mainly do the changes: have a look at BaseTransCFJava (and StackTransCFJava) how it's done currently
  createWrap = \name exp ->
        do (bs,e,t) <- translateM super exp
           let returnType = case t of JClass "java.lang.Integer" -> Just $ J.PrimType $ J.IntT
                                      _ -> Just objClassTy
           let paraType = getParaType t
           let classDecl = BenchGenCF2J.getClassDecl name bs ([J.BlockStmt (J.Return $ Just (unwrap e))]) paraType testfuncBody returnType mainBody
           return (BenchGenCF2J.createCUB super [classDecl], t)
   }
}



-- data type for naive + apply opt BenchGen
data BenchGenTranslateOpt m = TBA {
  toTBA :: Translate m -- supertype is a subtype of Translate (later on at least)
}

instance (:<) (BenchGenTranslateOpt m) (Translate m) where
   up = up . toTBA

instance (:<) (BenchGenTranslateOpt m) (BenchGenTranslateOpt m) where -- reflexivity
  up = id

transBenchOpt :: (MonadState Int m, MonadState (Set.Set J.Exp) m, MonadReader InitVars m, selfType :< BenchGenTranslateOpt m, selfType :< Translate m) => Mixin selfType (Translate m) (BenchGenTranslateOpt m)
transBenchOpt this super = TBA {
  toTBA = super {
  createWrap = \name exp ->
        do (bs,e,t) <- translateM super exp
           let returnType = case t of JClass "java.lang.Integer" -> Just $ J.PrimType $ J.IntT
                                      _ -> Just objClassTy
           let paraType = getParaType t
           let classDecl = BenchGenCF2J.getClassDecl name bs ([J.BlockStmt (J.Return $ Just (unwrap e))]) paraType testfuncBody returnType mainBody
           return (BenchGenCF2J.createCUB super [classDecl], t)
   }
}


<|start_filename|>frontend/abstractsyntax/SystemFI.hs<|end_filename|>
{-# LANGUAGE FlexibleInstances, RankNTypes #-}

{- |
Module      :  SystemFI
Description :  Abstract syntax and pretty printer for SystemFI.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>, <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module SystemFI
  ( Type(..)
  , Expr(..)
  , FExp(..)
  , Constructor(..)
  , Alt(..)
  , DataBind(..)
  , Definition(..)
--, TypeContext
--, ValueContext
--, Index
--, alphaEq
  , mapTVar
--, mapVar
  , fsubstTT
  , fsubstTE
  , fsubstEE
  , joinType
  , prettyType
  , prettyExpr
  ) where

import           JavaUtils
import           PrettyUtils
import qualified Src

import           Control.Arrow (second)
import           Data.List (intersperse)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Language.Java.Pretty (prettyPrint)
import           Prelude hiding ((<$>))
import           Text.PrettyPrint.ANSI.Leijen

data Type t
  = TVar Src.Name t                 -- a
  | JClass ClassName                    -- C
  | Fun (Type t) (Type t)               -- t1 -> t2
  | Forall Src.Name (t -> Type t)   -- forall a. t
  | Product [Type t]                    -- (t1, ..., tn)
  | Unit
  -- Extensions
  | And (Type t) (Type t)               -- t1 & t2
  | RecordType (Src.Label, Type t)
  | Datatype Src.Name [Type t] [Src.Name]
    -- Warning: If you ever add a case to this, you *must* also define the
    -- binary relations on your new case. Namely, add cases for your data
    -- constructor in `alphaEq' (below) and `coerce' (in Simplify.hs). Consult
    -- George if you're not sure.

data Definition t e = Def Src.Name (Src.Type, Type t) (Expr t e) (e -> Definition t e)
                    | DefRec [Src.Name] [(Src.Type, Type t)] ([e] -> [Expr t e]) ([e] -> Definition t e)
                    | Null

data Expr t e
  = Var Src.Name e
  | Lit Src.Lit

  -- Binders we have: λ, fix, letrec, and Λ
  | Lam Src.Name (Type t) (e -> Expr t e)
  | Fix Src.Name Src.Name
        (e -> e -> Expr t e)
        (Type t)  -- t1
        (Type t)  -- t
      -- fix x (x1 : t1) : t. e     Syntax in the tal-toplas paper
      -- fix (x : t1 -> t). \x1. e  Alternative syntax, which is arguably clear
      -- <name>: Fix funcName paraName func paraType returnType
  | Let Src.Name (Expr t e) (e -> Expr t e)
  | LetRec [Src.Name]           -- Names
           [Type t]                 -- Signatures
           ([e] -> [Expr t e])      -- Bindings
           ([e] -> Expr t e)        -- Body
  | BLam Src.Name (t -> Expr t e)

  | App  (Expr t e) (Expr t e)
  | TApp (Expr t e) (Type t)

  | If (Expr t e) (Expr t e) (Expr t e)
  | PrimOp (Expr t e) Src.Operator (Expr t e)
      -- SystemF extension from:
      -- https://www.cs.princeton.edu/~dpw/papers/tal-toplas.pdf
      -- (no int restriction)

  | Tuple [Expr t e]     -- Tuple introduction
  | Proj Int (Expr t e)  -- Tuple elimination

  -- Module
  | Module (Maybe Src.PackageName) (Definition t e)

  -- Java
  | JNew ClassName [Expr t e]
  | JMethod (Src.JReceiver (Expr t e)) MethodName [Expr t e] ClassName
  | JField  (Src.JReceiver (Expr t e)) FieldName (Type t)

  | Seq [Expr t e]

  | Merge (Expr t e) (Expr t e)  -- e1 ,, e2
  | RecordCon    (Src.Label, Expr t e)
  | RecordProj   (Expr t e) Src.Label
  | RecordUpdate (Expr t e) (Src.Label, Expr t e)

  | Data Src.RecFlag [DataBind t] (Expr t e)
  | ConstrOut (Constructor t) [Expr t e]
  | Case (Expr t e) [Alt t e]

  | Error (Type t) (Expr t e)

newtype FExp = HideF { revealF :: forall t e. Expr t e }

data Alt t e = ConstrAlt (Constructor t) (Expr t e)
             | Default (Expr t e)

data DataBind t = DataBind Src.Name [Src.Name] ([t] -> [Constructor t])
data Constructor t = Constructor {constrName :: Src.Name, constrParams :: [Type t]}
-- newtype Typ = HideTyp { revealTyp :: forall t. Type t } -- type of closed types

-- newtype Exp = HideExp { revealExp :: forall t e. Expr t e }

type TypeContext t    = Set.Set t
type ValueContext t e = Map.Map e (Type t)

type Index = Int

alphaEq :: Int -> Type Index -> Type Index -> Bool
alphaEq _ (TVar _ a)   (TVar _ b)   = a == b
alphaEq _ (JClass c)   (JClass d)   = c == d
alphaEq i (Fun s1 s2)  (Fun t1 t2)  = alphaEq i s1 t1 && alphaEq i s2 t2
alphaEq i (Forall _ f) (Forall _ g) = alphaEq (succ i) (f i) (g i)
alphaEq i (Product ss) (Product ts) = length ss == length ts && uncurry (alphaEq i) `all` zip ss ts
alphaEq _  Unit     Unit            = True
alphaEq i (And s1 s2)  (And t1 t2)  = alphaEq i s1 t1 && alphaEq i s2 t2
alphaEq _ _            _            = False

mapTVar :: (Src.Name -> t -> Type t) -> Type t -> Type t
mapTVar g (TVar n a)     = g n a
mapTVar _ (JClass c)     = JClass c
mapTVar g (Fun t1 t2)    = Fun (mapTVar g t1) (mapTVar g t2)
mapTVar g (Forall n f)   = Forall n (mapTVar g . f)
mapTVar g (Product ts)   = Product (map (mapTVar g) ts)
mapTVar _  Unit          = Unit
mapTVar g (And t1 t2)    = And (mapTVar g t1) (mapTVar g t2)
mapTVar g (RecordType (l,t)) = RecordType (l, mapTVar g t)
mapTVar g (Datatype n ts ns)  = Datatype n (map (mapTVar g) ts) ns

mapVar :: (Src.Name -> e -> Expr t e) -> (Type t -> Type t) -> Expr t e -> Expr t e
mapVar g _ (Var n a)                 = g n a
mapVar _ _ (Lit n)                   = Lit n
mapVar g h (Lam n t f)               = Lam n (h t) (mapVar g h . f)
mapVar g h (BLam n f)                = BLam n (mapVar g h . f)
mapVar g h (Fix n1 n2 f t1 t)        = Fix n1 n2 (\x x1 -> mapVar g h (f x x1)) (h t1) (h t)
mapVar g h (Let n b e)               = Let n (mapVar g h b) (mapVar g h . e)
mapVar g h (LetRec ns ts bs e)       = LetRec ns (map h ts) (map (mapVar g h) . bs) (mapVar g h . e)
mapVar g h (Data rec databinds e)    = Data rec (map mapDatabind databinds) (mapVar g h e)
    where mapDatabind (DataBind name params ctrs) = DataBind name params (map mapCtr . ctrs)
          mapCtr (Constructor n ts) = Constructor n (map h ts)
mapVar g h (ConstrOut (Constructor n ts) es) = ConstrOut c' (map (mapVar g h) es)
    where c' = Constructor n (map h ts)
mapVar g h (Case e alts)             = Case (mapVar g h e) (map mapAlt alts)
    where mapAlt (ConstrAlt (Constructor n ts) e1) = ConstrAlt (Constructor n (map h ts)) (mapVar g h e1)
          mapAlt (Default e1) = Default (mapVar g h e1)
mapVar g h (App f e)                 = App (mapVar g h f) (mapVar g h e)
mapVar g h (TApp f t)                = TApp (mapVar g h f) (h t)
mapVar g h (If p b1 b2)              = If (mapVar g h p) (mapVar g h b1) (mapVar g h b2)
mapVar g h (PrimOp e1 op e2)         = PrimOp (mapVar g h e1) op (mapVar g h e2)
mapVar g h (Tuple es)                = Tuple (map (mapVar g h) es)
mapVar g h (Proj i e)                = Proj i (mapVar g h e)
mapVar g h (JNew c args)             = JNew c (map (mapVar g h) args)
mapVar g h (JMethod callee m args c) = JMethod (fmap (mapVar g h) callee) m (map (mapVar g h) args) c
mapVar g h (JField  callee f c)      = JField (fmap (mapVar g h) callee) f (h c)
mapVar g h (Error ty str)            = Error (h ty) (mapVar g h str)
mapVar g h (Seq es)                  = Seq (map (mapVar g h) es)
mapVar g h (Merge e1 e2)             = Merge (mapVar g h e1) (mapVar g h e2)
mapVar g h (RecordCon (l, e))        = RecordCon (l, mapVar g h e)
mapVar g h (RecordProj e l)          = RecordProj (mapVar g h e) l
mapVar g h (RecordUpdate e (l1,e1))  = RecordUpdate (mapVar g h e) (l1, mapVar g h e1)
mapVar g h (Module pname defs) = Module pname (mapVarDefs defs)
  where
    -- necessary?
    mapVarDefs Null = Null
    mapVarDefs (Def n t expr def) = Def n t (mapVar g h expr) (mapVarDefs . def)
    mapVarDefs (DefRec names types exprs def) =
      DefRec names (map (second h) types) (map (mapVar g h) . exprs) (mapVarDefs . def)



fsubstTT :: Eq a => a -> Type a -> Type a -> Type a
fsubstTT x r = mapTVar (\n a -> if a == x then r else TVar n a)

fsubstTE :: Eq t => t -> Type t -> Expr t e -> Expr t e
fsubstTE x r = mapVar Var (fsubstTT x r)

fsubstEE :: Eq a => a -> Expr t a -> Expr t a -> Expr t a
fsubstEE x r = mapVar (\n a -> if a == x then r else Var n a) id


joinType :: Type (Type t) -> Type t
joinType (TVar n a)       = a
joinType (JClass c)       = JClass c
joinType (Fun t1 t2)      = Fun (joinType t1) (joinType t2)
joinType (Forall n g)     = Forall n (joinType . g . TVar "_") -- Right?
joinType (Product ts)     = Product (map joinType ts)
joinType  Unit            = Unit
joinType (And t1 t2)      = And (joinType t1) (joinType t2)
joinType (RecordType (l,t))   = RecordType (l, joinType t)
joinType (Datatype n ts ns)  = Datatype n (map joinType ts) ns

-- instance Show (Type Index) where
--   show = show . pretty

-- instance Pretty (Type Index) where
--   pretty = prettyType

prettyType :: Type Index -> Doc
prettyType = prettyType' basePrec 0

prettyType' :: Prec -> Index -> Type Index -> Doc

prettyType' _ _ (TVar n a)   = text n

prettyType' p i (Datatype n ts _) = hsep $ text n : map (prettyType' p i) ts

prettyType' p i (Fun t1 t2)  =
  parensIf p 2
    (prettyType' (2,PrecPlus) i t1 <+> arrow <+> prettyType' (2,PrecMinus) i t2)

prettyType' p i (Forall n f)   =
  parensIf p 1
    (forall <+> text n <> dot <+>
     prettyType' (1,PrecMinus) (succ i) (f i))

prettyType' _ i (Product ts) = parens $ hcat (intersperse comma (map (prettyType' basePrec i) ts))

prettyType' _ _  Unit = text "Unit"

prettyType' _ _ (JClass "java.lang.Integer")   = text "Int"
prettyType' _ _ (JClass "java.lang.String")    = text "String"
prettyType' _ _ (JClass "java.lang.Boolean")   = text "Bool"
prettyType' _ _ (JClass "java.lang.Character") = text "Char"
prettyType' _ _ (JClass c)                     = text c

prettyType' p i (And t1 t2) =
  parensIf p 2
    (prettyType' (2,PrecMinus) i t1 <+>
     ampersand  <+>
     prettyType' (2,PrecPlus) i t2)

prettyType' _ i (RecordType (l,t)) = lbrace <+> text l <+> colon <+> prettyType' basePrec i t <+> rbrace

-- instance Show (Expr Index Index) where
--   show = show . pretty

-- instance Pretty (Expr Index Index) where
--   pretty = prettyExpr

prettyDef :: Prec -> (Index, Index) -> Definition Index Index -> Doc
prettyDef _ (i, j) (Def fname typ e def) =
  text fname <+> colon <+> pretty (fst typ) <+> equals <+> prettyExpr' basePrec (i, j + 1) e <> semi <$>
  prettyDef basePrec (i, j+1) (def j) -- crappy pretty printer

prettyDef p (i, j) (DefRec names sigs binds def) = vcat (intersperse (text "and") pretty_binds) <> semi <$> pretty_body
  where
    n = length sigs
    ids = [i .. (i + n) - 1]
    pretty_ids = map text names
    pretty_sigs = map (pretty . fst) sigs
    pretty_defs = map (prettyExpr' p (i, j + n)) (binds ids)
    pretty_binds = zipWith3
                     (\pretty_id pretty_sig pretty_def ->
                        pretty_id <+> colon <+> pretty_sig <$> indent 2 (equals <+> pretty_def))
                     pretty_ids
                     pretty_sigs
                     pretty_defs
    pretty_body = prettyDef p (i, j + n) (def ids)

prettyDef _ _ Null = text ""

prettyExpr :: Expr Index Index -> Doc
prettyExpr = prettyExpr' basePrec (0, 0)

prettyExpr' :: Prec -> (Index, Index) -> Expr Index Index -> Doc

prettyExpr' _ _ (Var n _) = text n

prettyExpr' p (i,j) (Lam n t f)
  = parensIf p 2 $ group $ hang 2 $
      lambda <+> parens (text n <+> colon <+> prettyType' basePrec i t) <> dot <$>
      prettyExpr' (2,PrecMinus) (i, j + 1) (f j)

prettyExpr' p (i,j) (App e1 e2)
  = parensIf p 4 $
      group $ hang 2 $ prettyExpr' (4,PrecMinus) (i,j) e1 <$> prettyExpr' (4,PrecPlus) (i,j) e2

prettyExpr' p (i,j) (BLam n f) =
  parensIf p 2
    (biglambda <+> text n <> dot <+>
     prettyExpr' (2,PrecMinus) (succ i, j) (f i))

prettyExpr' p (i,j) (TApp e t) =
  parensIf p 4
    (group $ hang 2 $ prettyExpr' (4,PrecMinus) (i,j) e <$> prettyType' (4,PrecPlus) i t)

prettyExpr' _ _ (Lit (Src.Int n))    = integer n
prettyExpr' _ _ (Lit (Src.String s)) = dquotes (string s)
prettyExpr' _ _ (Lit (Src.Bool b))   = bool b
prettyExpr' _ _ (Lit (Src.Char c))   = char c
prettyExpr' _ _ (Lit Src.UnitLit)    = unit

prettyExpr' p (i,j) (If e1 e2 e3)
  = parensIf p prec
      (hang 3 (text "if"   <+> prettyExpr' (prec,PrecMinus) (i,j) e1 <+>
               text "then" <+> prettyExpr' (prec,PrecMinus) (i,j) e2 <+>
               text "else" <+> prettyExpr' (prec,PrecMinus) (i,j) e3))
  where prec = 3

prettyExpr' p (i,j) (PrimOp e1 op e2)
  = parens (prettyExpr' p (i,j) e1 <+> pretty_op <+> prettyExpr' p (i,j) e2)
  where
    pretty_op = text (Language.Java.Pretty.prettyPrint java_op)
    java_op   = case op of
                  Src.Arith   op' -> op'
                  Src.Compare op' -> op'
                  Src.Logic   op' -> op'

prettyExpr' _ (i,j) (Tuple es) = tupled (map (prettyExpr' basePrec (i,j)) es)

prettyExpr' p i (Proj n e) =
  parensIf p 5
    (prettyExpr' (5,PrecMinus) i e <> dot <> char '_' <> int n)

prettyExpr' p i (Module pname defs) =
  maybe empty ((text "package" <+>) . pretty) pname <$> text "module" <> semi <$> prettyDef p i defs

prettyExpr' _ (i,j) (JNew c args) =
  parens (text "new" <+> text c <> tupled (map (prettyExpr' basePrec (i,j)) args))

prettyExpr' _ i (JMethod name m args _) = methodStr name <> dot <> text m <> tupled (map (prettyExpr' basePrec i) args)
  where
    methodStr (Src.Static x) = text x
    methodStr (Src.NonStatic x) = prettyExpr' (6,PrecMinus) i x

prettyExpr' _ i (JField name f _) = fieldStr name <> dot <> text f
  where
    fieldStr (Src.Static x) = text x
    fieldStr (Src.NonStatic x) = prettyExpr' (6,PrecMinus) i x

prettyExpr' p (i,j) (Seq es) = semiBraces (map (prettyExpr' p (i,j)) es)

prettyExpr' p (i,j) (Data recflag databinds e) =
  text "data" <+> (pretty recflag) <+> (align .vsep) (map prettyDatabind databinds) <$> prettyExpr' p (i,j) e
    where prettyCtr i' (Constructor ctrName ctrParams) = (text ctrName) <+> (hsep. map (prettyType' p i') $ ctrParams)
          prettyDatabind (DataBind n tvars cons) = hsep (map text $ n:tvars) <+> align
                 (equals <+> intersperseBar (map (prettyCtr (length tvars + i)) $ cons [i..length tvars +i-1]) <$$> semi)

prettyExpr' p i (Error _ str) = text "error:" <+> prettyExpr' p i str

prettyExpr' p (i,j) (Fix n1 n2 f t1 t)
  = parens $ group $ hang 2 $
      text "fix" <+> text n1 <+>
      parens (text n2 <+> colon <+> prettyType' p i t1) <+>
      colon <+> prettyType' p i t <> dot <$>
      prettyExpr' p (i, j + 2) (f j (j + 1))

prettyExpr' p (i,j) (Let n b e) =
  parensIf p 2 (text "let" <+> text n <+> equals <+> prettyExpr' basePrec (i, j + 1) b <$> text "in" <$>
  prettyExpr' basePrec (i, j + 1) (e j))

prettyExpr' p (i,j) (LetRec names sigs binds body)
  = text "let" <+> text "rec" <$>
    vcat (intersperse (text "and") (map (indent 2) pretty_binds)) <$>
    text "in" <$>
    pretty_body
  where
    n   = length sigs
    ids = [i..(i+n-1)]
    pretty_ids   = map text names
    pretty_sigs  = map (prettyType' p i) sigs
    pretty_defs  = map (prettyExpr' p (i, j + n)) (binds ids)
    pretty_binds = zipWith3 (\pretty_id pretty_sig pretty_def ->
                  pretty_id <+> colon <+> pretty_sig <$> indent 2 (equals <+> pretty_def))
                  pretty_ids pretty_sigs pretty_defs
    pretty_body  = prettyExpr' p (i, j + n) (body ids)

prettyExpr' p (i,j) (Merge e1 e2) =
  parens $ prettyExpr' p (i,j) e1 <+> dcomma <+> prettyExpr' p (i,j) e2

prettyExpr' _ (i,j) (RecordCon (l, e))       = lbrace <+> text l <+> equals <+> prettyExpr' basePrec (i,j) e <+> rbrace
prettyExpr' p (i,j) (RecordProj e l)         = prettyExpr' p (i,j) e <> dot <> text l
prettyExpr' p (i,j) (RecordUpdate e (l, e1)) = prettyExpr' p (i,j) e <+> text "with" <+> prettyExpr' p (i,j) (RecordCon (l, e1))

prettyExpr' p (i,j) (ConstrOut c es)            = parens $ hsep $ text (constrName c) : map (prettyExpr' p (i,j)) es

prettyExpr' p (i,j) (Case e alts) =
    hang 2 $ text "case" <+> prettyExpr' p (i,j) e <+> text "of" <$> align (intersperseBar (map pretty_alt alts))
    where pretty_alt (ConstrAlt c e1) =
               (text (constrName c) <+> arrow <+> (align $ prettyExpr' p (i, j) e1 ))
          pretty_alt (Default e1) =
               (text "_" <+> arrow <+> (align $ prettyExpr' p (i, j) e1 ))


<|start_filename|>repl/History.hs<|end_filename|>
{- |
Module      :  History
Description :  REPL command history
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  stable
Portability :  portable
-}

module History where
-- for :replay

type Hist = [String]

empty :: Hist
empty = []

insert :: Hist -> String -> Hist
insert xs cmd = cmd : xs


<|start_filename|>backend/StackTransCFJava.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts
           , FlexibleInstances
           , MultiParamTypeClasses
           , RankNTypes
           , ScopedTypeVariables
           , TypeOperators
           , UndecidableInstances #-}
{- |
Module      :  StackTransCFJava
Description :  Translation of FCore to Java with Stack-opt
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Tomas <<EMAIL>>
Stability   :  stable
Portability :  non-portable (MPTC)

This module augments the basic translation of FCore to Java to support
tail-call elimination.
-}

module StackTransCFJava where
-- TODO: isolate all hardcoded strings to StringPrefixes (e.g. Fun)

import qualified Language.Java.Syntax as J
import           Data.Maybe (fromJust)

import           BaseTransCFJava
import           ClosureF
import           Inheritance
import           JavaEDSL
import           MonadLib
import           StringPrefixes


data TranslateStack m = TS {
  toTS :: Translate m -- supertype is a subtype of Translate (later on at least)
  }

instance {-(r :< Translate m) =>-} (:<) (TranslateStack m) (Translate m) where
   up              = up . toTS

instance (:<) (TranslateStack m) (TranslateStack m) where -- reflexivity
  up = id

nextClass ::(Monad m) => Translate m -> m String
nextClass this = liftM2 (++) (getPrefix this) (return "Next")

whileApplyLoop :: (Monad m) => Translate m -> Bool -> String -> String -> J.Type -> J.Type -> m [J.BlockStmt]
whileApplyLoop this flag ctemp tempOut outType ctempCastTyp = do
  closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
  let closureType' = classTy closureClass
  nextName <- nextClass (up this)
  let doWhileStmts = [localVar closureType' (varDeclNoInit ctemp),
                      localVar outType (varDecl tempOut (case outType of
                                                          J.PrimType J.IntT -> J.Lit (J.Int 0) -- TODO: better choice?
                                                          _ -> J.Lit J.Null)),
                      bStmt (J.Do (J.StmtBlock (block [bsAssign (name [ctemp]) (J.ExpName $ name [nextName, "next"])
                                                      ,bsAssign (name [nextName, "next"]) (J.Lit J.Null)
                                                      ,bStmt (methodCall [ctemp, "apply"] [])]))
                             (J.BinOp (J.ExpName $ name [nextName, "next"])
                              J.NotEq
                              (J.Lit J.Null))),
                      bsAssign (name [tempOut]) (cast outType (J.FieldAccess (fieldAccExp (cast ctempCastTyp (left $ var ctemp)) closureOutput)))]
  if flag -- False means stack with apply
    then return doWhileStmts
    else return (let (l1,l2) = splitAt 2 doWhileStmts
                 in head l1:l2)

whileApplyLoopMain :: (Monad m) => Translate m -> String -> String -> J.Type -> J.Type -> m [J.BlockStmt]
whileApplyLoopMain this ctemp tempOut outType ctempCastTyp =
  do closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
     let closureType' = classTy closureClass
     nextName <- nextClass (up this)
     let nextNEqNull = J.BinOp (J.ExpName $ name [nextName,"next"]) J.NotEq (J.Lit J.Null)
     let loop =
           [bStmt (J.Do (J.StmtBlock
                           (block [bsAssign (name [ctemp]) (J.ExpName $ name [nextName,"next"])
                                  ,bsAssign (name [nextName,"next"])
                                          (J.Lit J.Null)
                                  ,bStmt (methodCall [ctemp,"apply"]
                                                     [])]))
                        nextNEqNull)
           ,bsAssign (name [tempOut]) (cast outType (J.FieldAccess (fieldAccExp (cast ctempCastTyp (left $ var ctemp)) closureOutput)))]
     return [localVar closureType' (varDeclNoInit ctemp)
            ,localVar outType (varDecl tempOut (J.MethodInv (J.MethodCall (name ["apply"]) [])))
            ,bStmt (J.IfThen nextNEqNull (J.StmtBlock (block loop)))]

containsNext :: [J.BlockStmt] -> Bool
containsNext =
  foldr ((||) .
         (\x ->
            case x of
              (J.BlockStmt (J.ExpStmt (J.Assign (J.NameLhs (J.Name [J.Ident _nextClass,J.Ident "next"])) J.EqualA _))) -> True
              _ -> False))
        False

-- ad-hoc fix for final-returned expressions in Stack translation
empyClosure :: Monad m => Translate m -> J.Exp -> String -> m J.BlockStmt
empyClosure this outExp box =
  do closureClass <- liftM (++ box) $ liftM2 (++) (getPrefix this) (return "Closure")
     nextName <- nextClass (up this)
     return (bsAssign (name [nextName,"next"])
                    (J.InstanceCreation
                       []
                       (classTyp closureClass)
                       []
                       (Just (classBody [memberDecl
                                           (methodDecl
                                              [annotation "Override",J.Public]
                                              (Just (classTy closureClass))
                                              "clone"
                                              []
                                              returnNull)
                                        ,memberDecl
                                           (methodDecl
                                              [annotation "Override",J.Public]
                                              Nothing
                                              "apply"
                                              []
                                              (Just (block [bsAssign (name [closureOutput]) outExp])))]))))

whileApply :: (Monad m) => Translate m -> Bool -> J.Exp -> String -> String -> J.Type -> J.Type -> m [J.BlockStmt]
whileApply this flag cl ctemp tempOut outType ctempCastTyp =
  do loop <- whileApplyLoop this flag ctemp tempOut outType ctempCastTyp
     nextName <- nextClass (up this)
     return (bsAssign (name [nextName,"next"]) cl : loop)

--e.g. Next.next = x8;
nextApply :: (Monad m) => Translate m -> J.Exp -> String -> J.Type -> m [J.BlockStmt]
nextApply this cl tempOut outType =
  do nextName <- nextClass this
     return [bsAssign (name [nextName,"next"]) cl
             ,localVar outType
                       (varDecl tempOut
                                (case outType of
                                   J.PrimType J.IntT -> J.Lit (J.Int 0)
                                   J.PrimType J.CharT -> J.Lit (J.Char 'a') --TODO: better default value?
                                   _ -> J.Lit J.Null))]

transS :: forall m selfType.
          (MonadState Int m,
           MonadReader Bool m,
           selfType :< TranslateStack m,
           selfType :< Translate m)
          => Mixin selfType (Translate m) (TranslateStack m)
transS this super =
  TS {toTS = super {

         translateM =
           \e ->
             case e of
               -- count abstraction as in tail position
               Lam _ _ -> local (True ||) $ translateM super e
               Fix{} -> local (True ||) $ translateM super e
               -- type application just inherits existing flag
               TApp _ _ -> translateM super e
               -- if e1 e2 e3: e1 can't be in tail position, e2 and e3 inherits flag
               If e1 e2 e3 ->
                 translateIf (up this) (local (False &&) $ translateM (up this) e1) (translateM (up this) e2) (translateM (up this) e3)
               App e1 e2 ->
                 translateApply (up this) False (local (False &&) $ translateM (up this) e1) (local (False &&) $ translateM (up this) e2)
               -- let e1 e2: e1 can't be in tail position, e2 inherits flag
               Let _ expr body ->
                 do (s1,j1,t1) <- local (False &&) $ translateM (up this) expr
                    translateLet (up this) (s1,j1,t1) body
               -- case scrutinee can't be in tail position, alts inherit flag
               Case scrut alts -> do
                      (scrutStmts, scrutExpr, _) <- local (False &&) $ translateM (up this) scrut
                      (altsStmts, varName, typ) <- transAlts (up this) scrutExpr alts
                      return (scrutStmts ++ altsStmts, varName, typ)
               -- the last expression in the sequence inherit flag
               SeqExprs es -> do
                 let allButLast = init es
                 let lastExpr = last es
                 emost <- mapM (local (False &&) . translateM (up this)) allButLast
                 (eLastStmt, eLastExpr, eLastType) <- translateM (up this) lastExpr
                 let statements = concatMap (\(x,_,_) -> x) emost
                 return (statements ++ eLastStmt, eLastExpr, eLastType)
               -- count other expressions as not in tail position
               _ -> local (False &&) $ translateM super e

         ,genApply =
            \f _ x jType ctempCastTyp ->
             do (tailPosition :: Bool) <- ask
                (n :: Int) <- get
                put (n + 1)
                flag <- withApply (up this) -- False means Stack with Apply
                if tailPosition
                  then nextApply (up this) f x jType
                  else whileApply (up this) flag f ("c" ++ show n) x jType ctempCastTyp
         ,genRes = \_ _ -> return []
         ,stackMainBody =
              \t ->
               do closureClass <- liftM2 (++) (getPrefix (up this)) (return "Closure")
                  retType <- applyRetType (up this) t
                  loop <- whileApplyLoopMain (up this) "c" "result" (fromJust retType) (classTy closureClass)
                  return (loop ++ [bStmt (classMethodCall (left $ var "System.out") "println" [left $ var "result"])])
         ,applyRetType =
                \t ->
                 (case t of
                   JClass "java.lang.Integer" -> return $ Just $ classTy "java.lang.Integer"
                   JClass "java.lang.Boolean" -> return $ Just $ classTy "java.lang.Boolean"
                   CFInt -> return $ Just $ classTy "java.lang.Integer"
                   _ -> return $ Just objClassTy)
         ,createWrap =
                  \nam expr ->
                   do (bs,e,t) <- translateM (up this) expr
                      returnType <- applyRetType (up this) t
                      let returnStmt = [bStmt $ J.Return $ Just (unwrap e)]
                      -- box <- getBox (up this) t
                      -- empyClosure' <- empyClosure (up this) (unwrap e) box
                      mainbody <- stackMainBody (up this) t
                      let stackDecl =
                            wrapperClass
                              False
                              nam
                              (bs ++
                               -- (if containsNext bs then [] else [empyClosure']) ++
                               returnStmt)
                              returnType (Just $ J.Block mainbody)
                      return (createCUB Nothing [stackDecl]
                             ,t)}}

-- Alternative version of transS that interacts with the Apply translation

transSA :: (MonadState Int m, MonadReader Bool m, selfType :< TranslateStack m, selfType :< Translate m) => Mixin selfType (Translate m) (TranslateStack m)
transSA this super = TS {toTS = (up (transS this super)) {
   withApply = return False
  }}

-- Alternative version of transS that interacts with the Unbox translation
-- transSU :: (MonadState Int m, MonadReader (Int, Bool) m, selfType :< TranslateStack m, selfType :< Translate m) => Mixin selfType (Translate m) (TranslateStack m)
-- transSU this super =
--   TS {toTS = (up (transS this super)) {
--          getBox = \t -> case t of
--                          CFInt -> return "BoxInt"
--                          _ -> return "BoxBox",
--          applyRetType = \t -> (case t of
--                                 JClass "java.lang.Integer" -> return $ Just $ J.PrimType J.IntT
--                                 JClass "java.lang.Boolean" -> return $ Just $ J.PrimType J.BooleanT
--                                 CFInt -> return $ Just $ J.PrimType J.IntT
--                                 _ -> return $ Just objClassTy),
--          stackMainBody = \t -> do
--            closureClass <- liftM2 (++) (getPrefix (up this)) (return "Closure")
--            let closureType' = classTy closureClass
--            nextName <- nextClass (up this)
--            let finalType = case t of
--                             CFInt -> "Int"
--                             _ -> "Box"
--            let resultType = case t of
--                              CFInt -> J.PrimType J.IntT
--                              CFChar -> J.PrimType J.CharT
--                              JClass "java.lang.Integer" -> classTy "java.lang.Integer"
--                              _ -> objClassTy

--            let nextNEqNull = J.BinOp (J.ExpName $ name [nextName, "next"])
--                              J.NotEq
--                              (J.Lit J.Null)

--            let loop = [bStmt (J.Do (J.StmtBlock (block [assign (name ["c"]) (J.ExpName $ name [nextName, "next"])
--                                                        ,assign (name [nextName, "next"]) (J.Lit J.Null)
--                                                        ,bStmt (methodCall ["c", "apply"] [])]))
--                               (J.BinOp (J.ExpName $ name [nextName, "next"])
--                                J.NotEq
--                                (J.Lit J.Null))),
--                        bStmt (J.IfThenElse
--                               (J.InstanceOf (left $ var "c") (J.ClassRefType $ classTyp (closureClass ++ "Int" ++ finalType)))
--                               (assignE
--                                 (name ["result"])
--                                 (cast resultType
--                                  (J.FieldAccess (fieldAccExp
--                                                  (cast (classTy (closureClass ++ "Int" ++ finalType)) (left $ var "c"))
--                                                  closureOutput))))
--                               (assignE
--                                (name ["result"])
--                                (cast resultType
--                                 (J.FieldAccess (fieldAccExp
--                                                 (cast (classTy (closureClass ++ "Box" ++ finalType)) (left $ var "c"))
--                                                 closureOutput)))))]

--            return (localVar closureType' (varDeclNoInit "c") :
--                    localVar resultType (varDecl "result" (J.MethodInv (J.MethodCall (name ["apply"]) []))) :
--                    bStmt (J.IfThen nextNEqNull (J.StmtBlock (block loop))) :
--                    [bStmt (classMethodCall (left $ var "System.out") "println" [left $ var "result"])])
--          }}


-- Alternative version of transS that interacts with the Unbox and Apply translation
-- transSAU :: (MonadState Int m, MonadReader (Int, Bool) m, selfType :< TranslateStack m, selfType :< Translate m) => Mixin selfType (Translate m) (TranslateStack m)
-- transSAU this super = TS {toTS = (up (transSU this super)) {
--    -- genRes = \t s -> if (last t) then return [] else genRes super t s
--   genApply = \f _ x jType ctempCastTyp ->
--       do (_ :: Int, tailPosition :: Bool) <- ask
--          (n :: Int) <- get
--          put (n+1)
--          if tailPosition
--            then nextApply (up this) f x jType
--            else whileApply (up this) False f ("c" ++ show n) x jType ctempCastTyp
--   }}


<|start_filename|>runtime/src/f2j/MyList.java<|end_filename|>
package f2j;

import java.util.LinkedList;

public class MyList {
  LinkedList<Integer> lst;

  public MyList() {
    lst = new LinkedList<Integer>();
  }

  public MyList cons(Integer x) {
    lst.addFirst(x);
    return this;
  }

  public Integer head() {
    if (lst.isEmpty())
      return 0;
    return lst.element();
  }

  public MyList tail() {
    lst.pop();
    return this;
  }

  public int length() {
    return lst.size();
  }

  public boolean isEmpty() {
    return lst.size() == 0;
  }

  public Integer at(int index) {
    return lst.get(index);
  }

  public static MyList genFuncList(int n) {
    MyList wh = new MyList();

    for (int i = n; i > 0; i --) {
      wh.cons(i % 5 + 1);
    }
    return wh;
  }

}


<|start_filename|>backend/UnboxTransCFJava.hs<|end_filename|>
{-# LANGUAGE RankNTypes, FlexibleInstances, FlexibleContexts, TypeOperators, MultiParamTypeClasses, ConstraintKinds, ScopedTypeVariables #-}

module UnboxTransCFJava where

import           Prelude hiding (init, last)
import qualified Language.Java.Syntax as J

import           BaseTransCFJava
import           ClosureF
import           Inheritance
import           JavaEDSL
import           JavaUtils
import           MonadLib
import           Panic
import qualified Src as S
import           StringPrefixes

data UnboxTranslate m = UT {toUT :: Translate m}

instance (:<) (UnboxTranslate m) (Translate m) where
   up              = up . toUT

instance (:<) (UnboxTranslate m) (UnboxTranslate m) where
   up              = id

getClassType :: (Monad m) => Translate m -> Type t -> Type t -> m ClassName
getClassType this t1 t2 = do
  closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
  case (t1, t2) of
   (CFInt, CFInt) -> return (closureClass ++ "IntInt")
   (CFInt, _) -> return (closureClass ++ "IntBox")
   (_, CFInt) -> return (closureClass ++ "BoxInt")
   (_, _) -> return (closureClass ++ "BoxBox")

boxType :: (Monad m) => Translate m -> m ClassName
boxType this = do
  closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
  return (closureClass ++ "BoxBox")


getFunType :: Type t -> (Type t, Type t)
getFunType (Forall (Type b f)) = (b, scope2ctyp (f ()))
getFunType _ = panic "UnboxTranslate.getFunType: expect Forall construcr"

--TODO: generate wrappers when types T1~T2
-- wrap :: J.Exp -> Type t -> Type t -> ([J.BlockStmt], J.Exp)
-- wrap e t1 t2 = ([], e)

transUnbox :: (MonadState Int m, selfType :< UnboxTranslate m, selfType :< Translate m) => Mixin selfType (Translate m) (UnboxTranslate m)
transUnbox this super =
  UT {toUT =
        super {translateM =
                 \e ->
                   case e of
                     TApp expr CFInt ->
                       do n <- get
                          (s,je,Forall (Kind f)) <- translateM (up this) expr
                          return (s,je,scope2ctyp (substScope n CFInteger (f n)))
                     Lit lit ->
                       case lit of
                         (S.Int i) -> return ([] ,Right $ J.Lit $ J.Int i ,CFInt)
                         (S.Char i) -> return ([] ,Right $ J.Lit $ J.Char i ,CFChar)
                         _ -> translateM super e
                     PrimOp e1 op e2 ->
                       do (s1,j1,_) <- translateM (up this) e1
                          (s2,j2,_) <- translateM (up this) e2
                          let j1' = unwrap j1
                          let j2' = unwrap j2
                          let (je,typ) =
                                case op of
                                  S.Arith realOp -> (J.BinOp j1' realOp j2',CFInt)
                                  S.Compare realOp -> (J.BinOp j1' realOp j2',JClass "boolean")
                                  S.Logic realOp -> (J.BinOp j1' realOp j2',JClass "boolean")
                          newVarName <- getNewVarName super
                          aType <- javaType (up this) typ
                          return (s1 ++ s2 ++ [localVar aType (varDecl newVarName je)],var newVarName,typ)
                     LetRec t xs body ->
                       do (n :: Int) <- get
                          let needed = length (xs (zip [n ..] t))
                          put (n + 2 + needed)
                          mfuns <- return (\defs -> forM (xs defs) (translateM (up this)))
                          let vars = liftM (map (\(_,b,c) -> (b,c))) (mfuns (zip [n ..] t))
                          let (bindings :: [Var]) = [n + 2 .. n + 1 + needed]
                          newvars <- liftM (pairUp bindings) vars
                          cNames <- mapM (\(_, typ) ->
                                           let (t1, t2) = getFunType typ
                                           in getClassType (up this) t1 t2)
                                    newvars
                          let varTypes = zip bindings cNames
                          let mDecls = map (\(x, typ) ->
                                              memberDecl (fieldDecl (classTy typ)
                                                                    (varDeclNoInit (localvarstr ++ show x))))
                                           varTypes
                          let finalFuns = mfuns newvars
                          let appliedBody = body newvars
                          let varnums = map fst newvars
                          (bindStmts,bindExprs,_) <- liftM unzip3 finalFuns
                          (bodyStmts,bodyExpr,t') <- translateM (up this) appliedBody
                          typ <- javaType (up this) t'
                          -- assign new created closures bindings to variables
                          let assm = map (\(i,jz) -> assign (name [localvarstr ++ show i]) jz)
                                         (varnums `zip` (map unwrap bindExprs))
                          let stasm = concatMap (\(a,b) -> a ++ [b]) (bindStmts `zip` assm) ++ bodyStmts ++ [assign (name ["out"]) (left bodyExpr)]
                          let letClass =
                                [localClass ("Let" ++ show n)
                                             (classBody (memberDecl (fieldDecl objClassTy (varDeclNoInit "out")) :
                                                         mDecls ++ [J.InitDecl False (J.Block stasm)]))
                                ,localVar (classTy ("Let" ++ show n))
                                          (varDecl (localvarstr ++ show n)
                                                   (instCreat (classTyp ("Let" ++ show n)) []))
                                ,localVar typ (varDecl (localvarstr ++ show (n + 1))
                                                       (cast typ (J.ExpName (name [localvarstr ++ show n, "out"]))))]
                          return (letClass,var (localvarstr ++ show (n + 1)),t')
                     _ -> translateM super e
              ,translateScopeM = \e m -> case e of
                   Type t g ->
                     do  n <- get
                         let (v,n')  = maybe (n+1,n+2) (\(i,_) -> (i,n+1)) m -- decide whether we have found the fixpoint closure or not
                         put (n' + 1)
                         let nextInClosure = g (n',t)

                         aType <- javaType (up this) t
                         let accessField = fieldAccess (left $ var (localvarstr ++ show v)) closureInput
                         let js = localFinalVar aType (varDecl (localvarstr ++ show n') (cast aType accessField))

                         let ostmts = translateScopeM (up this) nextInClosure Nothing
                         (_,_,tt) <- ostmts
                         cName <- getClassType (up this) t (scope2ctyp tt)

                         (cvar,t1) <- translateScopeTyp (up this) v n [js] nextInClosure ostmts cName
                         return (cvar,var (localvarstr ++ show n), Type t (\_ -> t1) )

                   _ -> translateScopeM super e m
              ,translateApply = \flag m1 m2 ->
                    do  (s1,j1', Forall (Type t1 g)) <- m1
                        (s2,j2,_) <- m2
                        -- let (wrapS, jS) = wrap j2 t1 t2
                        let retTyp = g ()
                        j1 <- genClosureVar (up this) flag (getArity retTyp) j1'
                        cName <- getClassType (up this) t1 (scope2ctyp retTyp)
                        (s3, nje3) <- getS3 (up this) j1 (unwrap j2) retTyp (classTy cName)
                        return (s1 ++ s2 ++ s3, nje3, scope2ctyp retTyp)
              ,javaType = \typ ->
                            case typ of
                              CFInt -> return $ J.PrimType J.IntT
                              CFChar -> return $ J.PrimType J.CharT
                              (Forall (Type t1 f)) -> case f () of
                                                        Body t2 -> liftM classTy (getClassType (up this) t1 t2)
                                                        _ -> liftM classTy (getClassType (up this) t1 CFInteger)
                              (Forall (Kind _)) -> liftM classTy (boxType (up this))
                              x -> javaType super x
              ,getPrefix = return (namespace ++ "unbox.")
              ,chooseCastBox = \typ ->
                                 case typ of
                                   CFInt -> return (\s e -> localFinalVar (J.PrimType J.IntT)
                                                                            (varDecl s (cast (J.PrimType J.IntT) e))
                                                   ,J.PrimType J.IntT)
                                   CFChar -> return (\s e -> localFinalVar (J.PrimType J.CharT)
                                                                            (varDecl s (cast (J.PrimType J.CharT) e))
                                                   ,J.PrimType J.CharT)
                                   (Forall (Type t1 f)) ->
                                     case f () of
                                       (Body t2) -> do
                                         typ1 <- getClassType (up this) t1 t2
                                         return (initClass typ1,classTy typ1)
                                       _ -> do
                                         typ1 <- getClassType (up this) t1 CFInteger
                                         return (initClass typ1,classTy typ1)
                                   t -> chooseCastBox super t
             }}


<|start_filename|>frontend/TestInh.hs<|end_filename|>
{-# OPTIONS -XTypeOperators -XMultiParamTypeClasses #-}

module TestInh where

-- class (:<) r1 r2  where
--   to :: r1 -> r2
--   override :: r1 -> (r2 -> r2) -> r1

newtype R1 = R1 {fun1 :: Int -> Int}

data R2 = R2 {toR1 :: R1, fun2 :: Int -> Int}

t1 this = R1 (\n -> if (n==0) then 1 else fun1 this (n-1))

t2 this = R2 (toR1 this) (\n -> if (n==1) then fun1 (toR1 this) n  else fun2 this (n-1))

new f = let r = f r in r

wrapT1 f this = R2 (f (toR1 this)) (fun2 this)

p = new (t2 . wrapT1 t1)

<|start_filename|>runtime/src/f2j/tuples/Tuple40.java<|end_filename|>
package f2j.tuples;

public class Tuple40 {
    public final Object _1, _2, _3, _4, _5, _6, _7, _8, _9, _10, _11, _12, _13, _14, _15, _16, _17, _18, _19, _20, _21, _22, _23, _24, _25, _26, _27, _28, _29, _30, _31, _32, _33, _34, _35, _36, _37, _38, _39, _40;

    public Tuple40(Object _1, Object _2, Object _3, Object _4, Object _5, Object _6, Object _7, Object _8, Object _9, Object _10, Object _11, Object _12, Object _13, Object _14, Object _15, Object _16, Object _17, Object _18, Object _19, Object _20, Object _21, Object _22, Object _23, Object _24, Object _25, Object _26, Object _27, Object _28, Object _29, Object _30, Object _31, Object _32, Object _33, Object _34, Object _35, Object _36, Object _37, Object _38, Object _39, Object _40) {
        this._1 = _1;
        this._2 = _2;
        this._3 = _3;
        this._4 = _4;
        this._5 = _5;
        this._6 = _6;
        this._7 = _7;
        this._8 = _8;
        this._9 = _9;
        this._10 = _10;
        this._11 = _11;
        this._12 = _12;
        this._13 = _13;
        this._14 = _14;
        this._15 = _15;
        this._16 = _16;
        this._17 = _17;
        this._18 = _18;
        this._19 = _19;
        this._20 = _20;
        this._21 = _21;
        this._22 = _22;
        this._23 = _23;
        this._24 = _24;
        this._25 = _25;
        this._26 = _26;
        this._27 = _27;
        this._28 = _28;
        this._29 = _29;
        this._30 = _30;
        this._31 = _31;
        this._32 = _32;
        this._33 = _33;
        this._34 = _34;
        this._35 = _35;
        this._36 = _36;
        this._37 = _37;
        this._38 = _38;
        this._39 = _39;
        this._40 = _40;
    }
}


<|start_filename|>frontend/Inheritance.hs<|end_filename|>
{-# OPTIONS -XTypeOperators -XMultiParamTypeClasses -XRankNTypes -XExistentialQuantification -XFlexibleContexts -XFlexibleInstances #-}

module Inheritance where

import Debug.Trace

class a :< b where
   up :: a -> b

type Base t a     = t -> a
type Mixin t s a  = t -> s -> a

(<.>) :: Mixin self b c -> Mixin self a b -> Mixin self a c
(<.>) f g = \this super -> f this (g this super)

($>) :: Mixin self a b -> Base self a -> Base self b
($>) f g = \this -> f this (g this)

new :: Base a a -> a
new f = let r = f r in r

data R1 = R {func :: Int -> Int}

data R2 = R2 {superR1 :: R1, gfunc :: Int -> Int}

instance R2 :< R1 where
   up = superR1

base :: (s :< R1) => Base s R1
base this = R {func = \n -> if (n == 0) then 0 else 1 + func (up this) (n-1)}

mix :: Mixin s R1 R2
mix this super = R2 (super {func = \n -> trace "Hello!" $ func super n})  (\n -> 1 + func super n)

test = new (mix $> base)



<|start_filename|>runtime/src/f2j/unbox/ClosureIntBox.java<|end_filename|>
package f2j.unbox;

public abstract class ClosureIntBox implements Closure
{
  public int arg;
  public Object res;
  public boolean hasApply = true;
  public abstract void apply () ;
  public ClosureIntBox clone () {
      return (ClosureIntBox) ((Object) this.clone());
  }
}


<|start_filename|>examples/case_studies/FeatherWeightJava.hs<|end_filename|>

{-# LANGUAGE TemplateHaskell #-}


module FWJava
       (Classname, Superclass, Fieldname,
        Variable, Methodname,
        CT,
        CL,
        Field,
        Constructor,
        Method,
        Term,
        fields,
        mtype,
        mbody,
        override,
        subtype,
        isValue,
        eval) where

import qualified Data.Map as Map
import Test.QuickCheck
import Test.QuickCheck.All
import Control.Monad
import System.CPUTime
import System.Timeout

type Classname = String
type Superclass = String
type Fieldname = String
type Variable = String
type Methodname = String
type CT = Map.Map Classname CL --a mapping from class to its CL

{-data Type = TyVar String
          | TyTop
          |
-}

data CL = Class Classname Superclass [Field] Constructor [Method] deriving Eq

data Field = Field Classname Fieldname deriving Eq

data Constructor = Mkcon Classname [Field] deriving Eq

data Method = Mkmtd Classname Methodname [Field] Term deriving Eq

data Term = Var Variable
          | FieAcc Term Fieldname
          | MetInv Term Methodname [Term]
          | New Classname [Term]
          | Cast Classname Term deriving Eq

{-
instance Arbitrary Term where
  arbitrary = sized arbTerm

arbTerm 0 = liftM Var (listOf (elements ['a'..'z']))
arbTerm n = frequency
          [ (1, liftM Var (listOf (elements ['a'..'z'])))
          , (1, liftM2 FieAcc (arbTerm (n `div` 2))
                              (listOf (elements ['a'..'z'])))
          , (1, liftM3 MetInv (arbTerm (n `div` 2))
                              (listOf (elements ['a'..'z']))
                              (listOf (arbTerm (n `div` 2))))
          , (1, liftM2 New (listOf (elements ['a'..'z']))
                           (listOf (arbTerm (n `div` 2))))
          , (1, liftM2 Cast (listOf (elements ['a'..'z']))
                            (arbTerm (n `div` 2)))  ]
-}

instance Arbitrary Term where
  arbitrary = sized arbTerm
arbTerm 0 = liftM Var (elements contextVa)
arbTerm n = frequency
          [ (1, liftM Var  (elements contextVa))
          , (1, liftM2 FieAcc (arbTerm (n `div` 6))
                              (elements contextFn))
          , (1, liftM3 MetInv (arbTerm (n `div` 6))
                              (elements contextMn)
                              (listOf (arbTerm (n `div` 6))))
          , (1, liftM2 New (elements context)
                           (listOf (arbTerm (n `div` 6))))
          , (1, liftM2 Cast (elements context)
                            (arbTerm (n `div` 6))) ]


----show----
mergeS :: [String] -> String
mergeS (x:xs) = x ++ (mergeS xs)
mergeS [] = " "

classdeclaration :: CL -> String
classdeclaration (Class cn sc f c m) = "class " ++ cn ++ " extends " ++
                                       sc ++ " {\n" ++ showFields f ++
                                       "\n" ++ (showCon c) ++ "\n" ++ (mergeS $ map showMethod m) ++ " }"

showField :: Field -> String
showField (Field cn fn) = cn ++ " " ++ fn

showFields :: [Field] -> String
showFields [] = ""
showFields (f:fs) = (showField f) ++ "; " ++ (showFields fs)

showCon :: Constructor -> String
showCon (Mkcon cn []) = cn ++ "() {super();}"
showCon (Mkcon cn f) = cn ++ "(" ++ (showFields f) ++ ") { super; this.f = f;}"

showMethod :: Method -> String
showMethod (Mkmtd cn mn f t) = cn ++ " " ++ mn ++ "(" ++ (showFields f) ++ ") {return " ++ (showTerm t) ++ ";}"

showTerm :: Term -> String
showTerm (Var v) = v
showTerm (FieAcc t fn) = "(" ++ (showTerm t) ++ "." ++ fn ++ ")"
showTerm (MetInv t m fn) = "(" ++ (showTerm t) ++ "." ++ m ++ "(" ++ (showTerms fn) ++ ")"++ ")"
showTerm (New cn t) = "new " ++ cn ++ "(" ++ (showTerms t) ++ ")"
showTerm (Cast cn t) = "(" ++ cn ++ ")" ++ (showTerm t)

--getValue :: Value -> String
--getValue (New cn v) = "new " ++ cn ++ "(" ++ (mergeS $ map getValue v) ++ ")"

showTerms :: [Term] -> String
showTerms [] = ""
showTerms (t:ts) = (showTerm t) ++ ", " ++ (showTerms ts)

instance Show CL where
 show = classdeclaration

instance Show Field where
 show = showField

instance Show Constructor where
 show = showCon

instance Show Method where
 show = showMethod

instance Show Term where
 show = showTerm

--instance Show Value where
-- show = getValue


---try----
ffst = Field "Object" "fst"
newfst = Field "Object" "newfst"
ssnd = Field "Object" "snd"
m = Mkmtd "Pair" "setfst" [newfst] (New "Pair" [(Var "newfst"), (FieAcc (Var "this") "snd")])
p = Class "Pair" "Object" [ffst,ssnd] (Mkcon "Pair" [(Field "Object" "fst"),(Field "Object" "snd")]) [m]
a = Class "A" "Object" [] (Mkcon "A" []) []
b = Class "B" "Object" [] (Mkcon "B" []) []
o = Class "Object" "Object" [] (Mkcon "Object" []) []
term =FieAcc (Cast "Pair" (FieAcc (New "Pair" [(New "Pair" [(New "A" []), (New "B" [])]), (New "A" [])]) "fst")) "snd"
this = "this"


-----some method

ct :: CT
ct = Map.insert "Object" o (Map.insert "B" b (Map.insert "A" a (Map.singleton "Pair" p)))

context :: [Classname]
context = Map.keys ct

contextFn :: [Fieldname]
contextFn = helper (Map.elems ct)
            where helper [] = []
                  helper (c1:cs) = case c1 of
                                   Class cc s fs c ms -> (fnsFromFs fs) ++ (helper cs)

contextMn :: [Methodname]
contextMn = helper (Map.elems ct)
            where helper [] = []
                  helper (c1:cs) = case c1 of
                                   Class cc s fs c ms -> (mnsFromMs ms) ++ (helper cs)

contextVa :: [Variable]
contextVa = "this":(map (:[]) ['a'..'z'])

mnsFromMs :: [Method] -> [Methodname]
mnsFromMs []     = []
mnsFromMs (m:ms) = case m of Mkmtd c m ts t -> m:(mnsFromMs ms)


--Field lookup
fields :: Classname -> [Field]
fields "Object" = []
fields cn = case (ct Map.! cn) of
                   (Class cn sc fs c ms) -> fs ++ (fields sc)

--Method type lookup
mtype :: Methodname -> Classname -> ([Classname], Classname)
mtype m cn = case (ct Map.! cn) of
                 (Class cn sc fs c ms) -> if Map.member m mapMs
                                          then case (mapMs Map.! m) of
                                               (Mkmtd b m bs t) -> ((cnsFromFs bs),b)
                                          else mtype m sc
                  where mapMs = methodstoMap ms

--helper function
methodstoMap :: [Method] -> Map.Map Methodname Method
methodstoMap [] = Map.empty
methodstoMap (m@(Mkmtd cn mn fs t):ms) = Map.insert mn m (methodstoMap ms)

cnsFromFs :: [Field] -> [Classname]
cnsFromFs [] = []
cnsFromFs ((Field cn fn):fs) = (:) cn (cnsFromFs fs)


--Method body lookup
mbody :: Methodname -> Classname -> ([Fieldname], Term)
mbody m cn = case (ct Map.! cn) of
                 (Class cn sc fs c ms) -> if Map.member m mapMs
                                          then case (mapMs Map.! m) of
                                               (Mkmtd b m bs t) -> ((fnsFromFs bs),t)
                                          else mbody m sc
                  where mapMs = methodstoMap ms

--helper function
fnsFromFs :: [Field] -> [Fieldname]
fnsFromFs [] = []
fnsFromFs ((Field cn fn):fs) = fn : (fnsFromFs fs)


--Valid method overriding : judge whether a method m is defined in a subclass of D
override :: Methodname -> Classname -> ([Classname],Classname) -> Bool
override m d (cs,c0) = case (mtype m d) of
                           (ds,d0) -> ds == cs && c0 == d0


--subtyping
subtype :: Classname -> Classname -> Bool
subtype c e = if c == e
              then True
              else if case (ct Map.! c) of
                      (Class c sc fs co ms) -> e == sc
                   then True
                   else or [subtype c d && subtype d e | d <- context, c /= d, e /= d]


-----evaluation
isValue :: Term -> Bool
isValue (New cn ts) = and (map isValue ts)
isValue _ = False

eval1 :: Term -> Term
-- E-PROJNEW
eval1 (FieAcc c@(New cn ts) fn) = if isValue c
                                  then if elem fn (fnsFromFs $ fields cn)
                                       then ts !! (seeOrder fn (fields cn))
                                       else error "There is no such field"
                                  else FieAcc (eval1 c) fn -- E-FIELD
-- E-INVKNEW
eval1 (MetInv c@(New cn ts) m ar) = if isValue c
                                    then let (xs,t0) = (mbody m cn)
                                         in subst [this] [c] (subst xs ar t0)--danger
                                    else MetInv (eval1 c) m ar  -- E-INVK-RECV
-- E-CASTNEW
eval1 (Cast d (New c vs)) = if subtype c d
                            then New c vs
                            else error "Cast error"
-- E-FIELD
eval1 (FieAcc t f) = FieAcc (eval1 t) f
-- E-INVK-ARG
eval1 (MetInv c m ar) = if isValue c && (or (map isValue ar))
                        then MetInv c m (map helper ar)
                        else MetInv (eval1 c) m ar
                        where helper = (\x-> if isValue x then x else eval1 x)
-- E-NEW-ARG
eval1 (New c vs) = New c (map helper vs)
                   where helper = (\x-> if isValue x then x else eval1 x)
-- E-CAST
eval1 (Cast c t0) = Cast c (eval1 t0)
eval1 t           = t --error "No Evaluation rules applied"


seeOrder :: Fieldname -> [Field] -> Int
seeOrder fn f@(fi@(Field c f1):fs) = if fn == f1 then 0 else 1 + (seeOrder fn fs)

subst :: [Fieldname] -> [Term] -> Term -> Term
subst [] ts t = t
subst fs [] t = t
subst fs ts t = if length fs /= length ts then error "Do not have suffice substition"
                else helper1 (size t) t
                where mapFsTs = zip (helper fs) ts
                      helper []     = []
                      helper (t:ts) = (Var t):(helper ts)
                      helper1 0 t   = t
                      helper1 n t   = helper1 (n-1) (move t mapFsTs)

move :: Term -> [(Term,Term)] -> Term
move t@(Var v) (m:ms)           = if (fst m) == t then snd m else move t ms
move t@(FieAcc t1 fn) (m:ms)    = if (fst m) == t1 then FieAcc (snd m) fn else move t ms
move t@(MetInv t1 mn ar) (m:ms) = if (fst m) == t1 then MetInv (snd m) mn ar else move t ms
move t@(New cn ts) ma           = if ts == [] then t else New cn (map helper ts)
                                  where helper = (\x -> move x ma)
move t@(Cast cn t1) (m:ms)      = if (fst m) == t1 then Cast cn (snd m) else move t ms
move t []                       = t

size :: Term -> Int
size (Var v) = 1
size (FieAcc t fn)   = 1 + (size t)
size (MetInv t m ts) = 1 + (size t) + (sum $ map size ts)
size (New c ts)      = 1 + (sum $ map size ts)
size (Cast c t)      = 1 + (size t)


eval :: Term -> Term
eval t = helper ((size t)*2) t
         where helper 0 t = t
               helper n t = helper (n-1) (eval1 t)


prop_eval :: Term -> Bool
prop_eval (Var v) = True
prop_eval t = isValue $ eval t

prop_try :: Term -> Bool
prop_try t = t /= New "A" []



------timer--------------------------------------------------

timeIt :: (Fractional c) => (a -> IO b) -> a -> IO c
timeIt action arg = do
       startTime <- getCPUTime
       action arg
       finishTime <- getCPUTime
       return $ fromIntegral (finishTime - startTime)  / 1000000000

--timeIt' :: (Fractional c) => (a -> b) -> a -> IO c
--timeIt' f = timeIt (\x -> f x `seq` return())

oneTestNv = timeout 5000000 $ timeIt quickCheck prop_tryNv >>= print --change prop here
--oneTestCl = timeout 5000000 $ timeIt quickCheck prop_tryCl >>= print --change prop here

multiTestNv = do
            startTime <- getCPUTime
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000

{-
multiTestCl = do
            startTime <- getCPUTime
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000
-}

-----------------------------------------------------------------------------------------


------for-quickCheck-test-------
return []                     --
runTests = $quickCheckAll     --
--------------------------------


<|start_filename|>backend/newlib/TransEnvironment.hs<|end_filename|>
{-# LANGUAGE OverloadedStrings, TemplateHaskell, FlexibleContexts #-}

module TransEnvironment (
    lookupTy,
    extendCtx,
    multiSubst,
    Context,
    oneStep,
    initialEnv
    ) where

import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Lens.Micro
import Lens.Micro.TH
import Unbound.Generics.LocallyNameless

import Panic
import PrettyPrint
import Syntax


data Context = Ctx {_env :: Tele}

makeLenses ''Context

-- type TcMonad = FreshMT (ReaderT Context (Except T.Text))


-- runTcMonad :: Context -> TcMonad a -> (Either T.Text a)
-- runTcMonad env m = runExcept $ runReaderT (runFreshMT m) env


-- dummyCtx :: Context
-- dummyCtx = Ctx Empty Prog Pos

initialEnv :: Context
initialEnv = Ctx Empty

lookUpTele :: TmName -> Tele -> Maybe Expr
lookUpTele _ Empty = Nothing
lookUpTele v (Cons rb)
  | v == x = return a
  | otherwise = lookUpTele v t'
  where
    ((x, Embed a), t') = unrebind rb

lookupTyMaybe :: MonadReader Context m => TmName -> m (Maybe Expr)
lookupTyMaybe v = do
  tele <- asks _env
  return (lookUpTele v tele)

lookupTy :: (MonadReader Context m) => TmName -> m Expr
lookupTy v = do
  x <- lookupTyMaybe v
  case x of
    Nothing  -> panic $ "Not in scope: " ++ show v
    Just res -> return res

extendCtx :: (MonadReader Context m) => Tele -> m a -> m a
extendCtx d = local (over env (`appTele` d))


appTele :: Tele -> Tele -> Tele
appTele Empty t2 = t2
appTele (Cons rb) t2 = Cons (rebind p (appTele t1' t2))
  where
    (p, t1') = unrebind rb

multiSubst :: Tele -> Expr -> Expr -> (Tele, Expr)
multiSubst Empty _ e = (Empty, e)
multiSubst (Cons rb) t e = (b', e')
  where
    ((x, _), b) = unrebind rb
    e' = subst x t e
    b' = subst x t b


done :: MonadPlus m => m a
done = mzero

-- | Small step, call-by-value operational semantics
step :: Expr -> MaybeT FreshM Expr
step (Var{}) = done
step (Star) = done
step (Lam{}) = done
step (Pi{}) = done
step (F{}) = done
step (Lit{}) = done
step (App (Lam bnd) t2) = do
  (delta, b) <- unbind bnd
  let (b', e') = multiSubst delta t2 b
  case b' of
    Empty -> return e'
    _     -> return (Lam (bind b' e'))
step (App t1 t2) =
  App <$> step t1 <*> pure t2
  <|> App <$> pure t1 <*> step t2
step (Let bnd) = do
  ((n, Embed e), b) <- unbind bnd
  let n' = name2String n
  elet n' <$> step e <*> pure b <|> pure (subst n e b)
step (U (F _ e)) = return e
step (U e) = U <$> step e
step e@(Mu bnd) = do
  ((n, _), b) <- unbind bnd
  return $ subst n e b
-- TODO: semantics for primop
-- step (PrimOp op (Lit n) (Lit m)) = do
--   let x = evalOp op
--   return (Lit (n `x` m))
step (PrimOp op e1 e2) =
  PrimOp <$> pure op <*> step e1 <*> pure e2
  <|> PrimOp <$> pure op <*> pure e1 <*> step e2

oneStep :: Expr -> Expr
oneStep e = do
  case runFreshM . runMaybeT $ (step e) of
    Nothing -> panic $ "Cannot reduce " ++ showExpr e
    Just e' -> e'


<|start_filename|>runtime/src/f2j/tuples/Tuple5.java<|end_filename|>
package f2j.tuples;

public class Tuple5 {
    public final Object _1, _2, _3, _4, _5;

    public Tuple5(Object _1, Object _2, Object _3, Object _4, Object _5) {
        this._1 = _1;
        this._2 = _2;
        this._3 = _3;
        this._4 = _4;
        this._5 = _5;
    }
}


<|start_filename|>testsuite/ParserSpec.hs<|end_filename|>
module ParserSpec where

import Control.Monad    (forM_)
import Test.Hspec

import Src
import Parser

import qualified Language.Java.Syntax as J (Op(..))

testCases :: [(String, ParsedExpr)]
testCases =
    [ ("((1,2),3)._0._1", Proj (Proj (Tuple [Tuple [Lit (Int 1), Lit (Int 2)], Lit (Int 3)]) 0) 1)
    , ("1 / 2 / (3 / 4)", PrimOp
                            (PrimOp (Lit (Int 1)) (Arith J.Div) (Lit (Int 2)))
                            (Arith J.Div)
                            (PrimOp (Lit (Int 3)) (Arith J.Div) (Lit (Int 4))))
    , ("1 2 3 4", App (App (App (Lit (Int 1)) (Lit (Int 2))) (Lit (Int 3))) (Lit (Int 4)))
    , ("1 2 (3 4)", App (App (Lit (Int 1)) (Lit (Int 2))) (App (Lit (Int 3)) (Lit (Int 4))))
    , ("1 (2 3) 4", App (App (Lit (Int 1)) (App (Lit (Int 2)) (Lit (Int 3)))) (Lit (Int 4)))
    , ("1 (2 3 4)", App (Lit (Int 1)) (App (App (Lit (Int 2)) (Lit (Int 3))) (Lit (Int 4))))
    , ("1 (2 (3 4))", App (Lit (Int 1)) (App (Lit (Int 2)) (App (Lit (Int 3)) (Lit (Int 4)))))
    , ("if 1 == 0 then 2 else 3 + 4", If (PrimOp (Lit (Int 1)) (Compare J.Equal) (Lit (Int 0))) (Lit (Int 2)) (PrimOp (Lit (Int 3)) (Arith J.Add) (Lit (Int 4))))
    , ("True", Lit (Bool True))
    , ("False", Lit (Bool False))
    , ("True && True", PrimOp (Lit (Bool True)) (Logic J.CAnd) (Lit (Bool True)))
    , ("False || True", PrimOp (Lit (Bool False)) (Logic J.COr) (Lit (Bool True)))
    , ("\"hello\"", Lit (String "hello"))
    ]

main :: IO ()
main = hspec spec

spec :: Spec
spec =
  describe "reader" $
    forM_ testCases (\(concr, abstr) ->
      it ("should parse \"" ++ concr ++ "\"") $
        reader concr `shouldBe` abstr)


<|start_filename|>runtime/src/f2j/Next.java<|end_filename|>
package f2j;

public class Next
{
  public static Closure next = null;
}


<|start_filename|>frontend/typecheck/TypeCheck.hs<|end_filename|>
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

{- |
Module      :  TypeCheck
Description :  Type checker for the source language.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>, <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

{- We make typechecking (this file) happen before desugaring (Desugar.hs) so that
the error messages presented to the programmer can be clearer. However, an
undesired consequence of such approach for the compiler implementer is that the
implementation of the typing rules does not follow strictly the formalization.
For instance, in the formalization there is no rule for handling multi-field
records as they are desugared into intersections of single-field records first.
But here we have to handle such cases.-}

module TypeCheck
  ( checkExpr

  -- For REPL
  , checkExprWithEnv
  , mkInitCheckerStateWithEnv
  , TypeError
  ) where

import Checker
import IOEnv
import JavaUtils
import qualified JvmTypeQuery
import Panic
import PrettyUtils
import Src hiding (subtype)
import qualified Src (subtype)
import SrcLoc
import StringUtils
import TypeErrors

import Control.Monad.Except
import Data.Data (toConstr)
import Data.List (findIndex, intercalate)
import Data.List.Split
import qualified Data.Map  as Map
import Data.Maybe (fromMaybe, isJust, fromJust)
import qualified Data.Set  as Set
import Text.PrettyPrint.ANSI.Leijen

import Prelude hiding (pred, (<$>))

checkExpr :: ParsedExpr -> IO (Either (Located TypeError) (Type, CheckedExpr))
checkExpr e = JvmTypeQuery.withConnection
                  (\conn -> (evalIOEnv (mkInitCheckerState conn) . runExceptT . inferExpr) e)

-- Temporary hack for REPL
checkExprWithEnv :: ValueContext -> ParsedExpr -> IO (Either (Located TypeError) (Type, CheckedExpr))
checkExprWithEnv value_ctxt e = JvmTypeQuery.withConnection (\conn ->
  (evalIOEnv (mkInitCheckerStateWithEnv value_ctxt conn) . runExceptT . inferExpr) e)


disjoint :: TypeContext -> Type -> Type -> Bool
disjoint ctxt (TVar a) t
  = case lookupTVarConstraint ctxt a of
       Nothing -> False
       Just c  -> Src.subtype ctxt c t && Src.subtype ctxt t c
  -- = case lookupTVar ctxt a of
  --     Nothing -> invariantFailed "Disjoint.disjoint:TVar" $ text "Not in scope:" <+> code (text a)
  --     Just result ->
  --       case result of
  --         IsTypeVar UnConstrained    -> False
  --         IsTypeVar (DisjointWith s) -> subtype s t
  --         -- Disjointness check shouldn't be aware of the type synonym feature.
  --         IsTypeAlias _  ->
  --           invariantFailed "Disjoint.disjoint:TVar" $
  --             text "Type alias" <+> code (text a) <+> text "should already have been eliminated"
disjoint ctxt t (TVar a) = disjoint ctxt (TVar a) t
disjoint ctxt (Fun _ s) (Fun _ t) = disjoint ctxt s t
disjoint ctxt (Forall v1 b1) (Forall v2 b2) = True -- TODO
disjoint ctxt (And s t) u         = disjoint ctxt s u && disjoint ctxt t u
disjoint ctxt s         (And t u) = disjoint ctxt s t && disjoint ctxt s u
disjoint ctxt Unit Unit = True -- Special case, since `Unit` contains only one value.
disjoint ctxt (TupleType types1) (TupleType types2)
  = length types1 /= length types2
  || any (uncurry (disjoint ctxt)) (zip types1 types2)
disjoint ctxt (RecordType fields1) (RecordType fields2)
  = Set.null (labels1 `Set.intersection` labels2)
  where
    labels1 = Set.fromList (map fst fields1)
    labels2 = Set.fromList (map fst fields2)
disjoint ctxt (JClass c1) (JClass c2) = c1 /= c2
disjoint ctxt (Datatype n1 _ _) (Datatype n2 _ _) = n1 /= n2
disjoint ctxt s         t
  | toConstr s /= toConstr t = True
  | otherwise                = False -- FIXME


-- | Kinding.
kind :: TypeContext -> Type -> IO (Maybe Kind)
kind d (TVar a)     = case Map.lookup a d of Nothing        -> return Nothing
                                             Just (k, _, _) -> return (Just k)
kind _  Unit        = return (Just Star)
kind d (Fun t1 t2)  = justStarIffAllHaveKindStar d [t1, t2]
kind d (Forall (a,_) t) = kind (addTVarToContext [(a, Star)] d) t
kind d (TupleType ts)  = justStarIffAllHaveKindStar d ts
kind d (RecordType fs) = justStarIffAllHaveKindStar d (map snd fs)
kind d (And t1 t2)  = justStarIffAllHaveKindStar d [t1, t2]

{-
    Δ,x::* ⊢ t :: k
    -------------------- (K-Abs) Restriction compared to F_omega: x can only have kind *
    Δ ⊢ λx. t :: * => k
-}
kind d (OpAbs x t) = do
  maybe_k <- kind (addTVarToContext [(x, Star)] d) t
  case maybe_k of
    Nothing -> return Nothing
    Just k  -> return $ Just (KArrow Star k)

{-
    Δ ⊢ t1 :: k11 => k12  Δ ⊢ t2 :: k11
    ------------------------------------ (K-App)
    Δ ⊢ t1 t2 :: k12
-}
kind d (OpApp t1 t2) = do
  maybe_k1 <- kind d t1
  maybe_k2 <- kind d t2
  case (maybe_k1, maybe_k2) of
    (Just (KArrow k11 k12), Just k2) | k2 == k11 -> return (Just k12)
    _ -> return Nothing

kind _ t = return (Just Star) -- TODO

justStarIffAllHaveKindStar :: TypeContext -> [Type] -> IO (Maybe Kind)
justStarIffAllHaveKindStar d ts
  = do ps <- mapM (hasKindStar d) ts
       if and ps
          then return (Just Star)
          else return Nothing

hasKindStar :: TypeContext -> Type -> IO Bool
hasKindStar d t
  = do k <- kind d t
       return (k == Just Star)

-- | Typing.
inferExpr :: ParsedExpr -> Checker (Type, CheckedExpr)
inferExpr this@(L loc (Var name)) = do
  resVar <- lookupVar name
  case resVar of
    Just t -> return (t, Var (name, t) `withLoc` this)
    Nothing -> throwError (NotInScope name `withLoc` this)

inferExpr (L loc (Lit lit)) = return (srcLitType lit, L loc $ Lit lit)

inferExpr (L loc (Lam (L loc_x1 x1, t1) e))
  = do checkType t1
       d <- getTypeContext
       let t1' = expandType d t1
       (t', e') <- withLocalVars [(x1,t1')] (inferExpr e)
       return (Fun t1' t', L loc $ Lam (L loc_x1 x1, t1') e')

inferExpr (L loc (App e1 e2)) =
  do (t1, e1') <- inferExpr e1
     (t2, e2') <- inferExpr e2

     case e1' of
       L loc (ConstrOut (Constructor n ts) es) ->
           case t1 of
             Fun t11 t12 ->
                 do result <- subtype t2 t11
                    unless result $ throwError (TypeMismatch t11 t2 `withLoc` e2)
                    return (t12, L loc $ ConstrOut (Constructor n (init ts ++ [t11,t12])) (es ++ [e2']))
             _ -> throwError (NotAFunction t1 `withLoc` e1)
       _ ->
        case t1 of
          -- Local type inference:
          -- `f[T] e` can be written as `f e` if the type of e is just T.
          Forall _ _ -> inferExpr (App (TApp e1 t2 `withLoc` e1) e2 `withLoc` e1)

          Fun t11 t12 ->
            do result <- subtype t2 t11
               unless result (throwError (TypeMismatch t11 t2 `withLoc` e2))
               return (t12, L loc (App e1' e2'))

          _ -> throwError (NotAFunction t1 `withLoc` e1)

inferExpr (L loc (BLam (a,c) e)) -- TODO: Issue: #addconstrainttocontext, check constraint
  = do case c of
         Just t  -> checkType t
         Nothing -> return ()
       (t, e') <- withLocalConstrainedTVars [(a, c)] (inferExpr e)
       return (Forall (a,c) t, L loc $ BLam (a,c) e')

inferExpr this@(L loc (TApp e arg))
  = do (t, e') <- inferExpr e
       checkType arg
       d <- getTypeContext
       let arg' = expandType d arg
       case t of
         Forall (a,c) t1 -> do
           case c of
             Nothing -> return ()
             Just t  -> do
               result <- subtype arg t
               when result (throwError (General (text "failed to satisfy disjoint constraint") `withLoc` this))
           let t' = fsubstTT (a, arg') t1 -- TODO: Issue: #addconstrainttocontext
           case e' of
             L loc' (ConstrOut (Constructor n _) es) -> return (t', L loc' $ ConstrOut (Constructor n [t']) es)
             _ -> return (t', L loc $ TApp e' arg')
         _ -> throwError (General (code (pretty e) <+> text "does not take type parameters") `withLoc` this)

inferExpr (L loc (TupleCon es))
  | length es < 2 = panic "TypeCheck.inferExpr: Tuple: fewer than two items"
  | otherwise     = do (ts, es') <- mapAndUnzipM inferExpr es
                       return (TupleType ts, L loc $ TupleCon es')

inferExpr this@(L _ (TupleProj e i))
  = do (t, e') <- inferExpr e
       case t of
         TupleType ts
           | 1 <= i && i <= length ts -> return (ts !! (i - 1), TupleProj e' i `withLoc` this)
           | otherwise -> throwError (General (text "tuple index out of range") `withLoc` this)
         _ -> throwError (General (text "this is not of a product type") `withLoc` e)

inferExpr (L loc (PrimOp e1 op e2)) =
  case op of
    Arith _ ->
      do (_, e1') <- inferAgainst e1 (JClass "java.lang.Integer")
         (_, e2') <- inferAgainst e2 (JClass "java.lang.Integer")
         return (JClass "java.lang.Integer", L loc $ PrimOp e1' op e2')
    Compare _ ->
      do (t1, e1') <- inferExpr e1
         (_ , e2') <- inferAgainst e2 t1
         return (JClass "java.lang.Boolean", L loc $ PrimOp e1' op e2')
    Logic _ ->
      do (_, e1') <- inferAgainst e1 (JClass "java.lang.Boolean")
         (_, e2') <- inferAgainst e2 (JClass "java.lang.Boolean")
         return (JClass "java.lang.Boolean", L loc $ PrimOp e1' op e2')

inferExpr (L loc (If e1 e2 e3))
  = do (_, e1')  <- inferAgainst e1 (JClass "java.lang.Boolean")
       (t2, e2') <- inferExpr e2
       (t3, e3') <- inferExpr e3
       d <- getTypeContext
       return (fromMaybe (panic message) (leastUpperBound d t2 t3), L loc $ If e1' e2' e3')
  where
    message = "inferExpr: least upper bound of types of two branches does not exist"

inferExpr (L loc (LetIn rec_flag binds e)) =
  do checkDupNames (map bindName binds)
     binds' <- case rec_flag of
                 NonRec -> mapM normalizeBind binds
                 Rec    -> do sigs <- collectBindIdSigs binds
                              withLocalVars sigs (mapM normalizeBind binds)
     (t, e') <- withLocalVars (map (\ (f,t,_) -> (f,t)) binds') (inferExpr e)
     return (t, L loc $ LetOut rec_flag binds' e')

inferExpr (L _ LetOut{}) = panic "TypeCheck.inferExpr: LetOut"

--  Case           Possible interpretations
--  ---------------------------------------
--  e.x            Field access, record elim
--  e.x ( )        Method invocation
--  e.x ()         Method invocation, application (of a unit lit)
--  e.x (g y)      Method invocation, application
--  e.x (g y,...)  Method invocation, application (of a tuple)

-- In all the cases of application except the first, it is impossible for `e.x`
-- to be a field access since field accesses cannot return something that
-- accepts a value as its argument (But with Java 8 lambdas? TODO.). So `e.x`
-- can only be a method invocation.

-- e.x
inferExpr this@(L _ (Dot e x Nothing)) =
  do (t, _) <- inferExpr e
     case t of
       JClass _     -> inferExpr (JField (NonStatic e) x undefined `withLoc` this)
       RecordType _ -> inferExpr (RecordProj e x `withLoc` this)
       And _ _      -> inferExpr (RecordProj e x `withLoc` this)
       _            -> throwError (NotMember x t `withLoc` this) -- TODO: should be x's loc

-- e.x ( )
inferExpr this@(L loc (Dot e x (Just ([], UnitImpossible)))) =
  do (t, _) <- inferExpr e
     case t of
       JClass _ -> inferExpr (JMethod (NonStatic e) x [] undefined `withLoc` this)
       _        -> throwError (NotMember x t `withLoc` this) -- TODO: should be x's loc

-- e.x ()
inferExpr this@(L loc (Dot e x (Just ([], UnitPossible)))) =
  do (t, _) <- inferExpr e
     case t of
       JClass _      -> inferExpr (L loc $ JMethod (NonStatic e) x [] undefined)
       RecordType _  -> inferExpr (L loc $ App (L loc $ RecordProj e x) (noLoc $ Lit UnitLit))
       And _ _       -> inferExpr (L loc $ App (L loc $ RecordProj e x) (noLoc $ Lit UnitLit))
       _             -> throwError (NotMember x t `withLoc` this) -- TODO: should be x's loc

-- e.x (a)
inferExpr this@(L loc (Dot e x (Just ([arg], _)))) =
  do (t, _) <- inferExpr e
     case t of
       JClass _     -> inferExpr (L loc $ JMethod (NonStatic e) x [arg] undefined)
       RecordType _ -> inferExpr (L loc $ App (L loc $ RecordProj e x) arg)
       And _ _      -> inferExpr (L loc $ App (L loc $ RecordProj e x) arg)
       _            -> throwError (NotMember x t `withLoc` this) -- TODO: should be x's loc

-- e.x (a,...)
inferExpr this@(L loc (Dot e x (Just (args, _)))) =
  do (t, _) <- inferExpr e
     case t of
       JClass _     -> inferExpr (L loc $ JMethod (NonStatic e) x args undefined)
       RecordType _ -> inferExpr (L loc $ App (L loc $ RecordProj e x) tuple)
       And _ _      -> inferExpr (L loc $ App (L loc $ RecordProj e x) tuple)
       _            -> throwError (NotMember x t `withLoc` this) -- TODO: should be x's loc
    where tuple = TupleCon args `withLocs` args

-- JNew, JMethod, and JField

inferExpr this@(L loc (JNew c args))
  = do checkClassName c
       (arg_cs, args') <- mapAndUnzipM inferAgainstAnyJClass args
       checkConstruction c arg_cs
       return (JClass c, L loc (JNew c args'))

inferExpr (L loc (JMethod receiver m args _)) =
  case receiver of
    Static c ->
      do (arg_cs, args') <- mapAndUnzipM inferAgainstAnyJClass args
         ret_c <- checkMethodCall (Static c) m arg_cs
         let ret_type = case ret_c of "java.lang.Void" -> Unit
                                      -- "char" -> JType (JPrim "char")
                                      _ -> JClass ret_c
         return (ret_type, L loc $ JMethod (Static c) m args' ret_c)
    NonStatic e ->
      do (c, e')         <- inferAgainstAnyJClass e
         (arg_cs, args') <- mapAndUnzipM inferAgainstAnyJClass args
         ret_c <- checkMethodCall (NonStatic c) m arg_cs
         let ret_type = case ret_c of "java.lang.Void" -> Unit
                                      -- "char" -> JType (JPrim "char")
                                      _ -> JClass ret_c
         return (ret_type, L loc $ JMethod (NonStatic e') m args' ret_c)

inferExpr this@(L loc (JField receiver f _)) =
  case receiver of
    Static c ->
      do ret_c <- checkFieldAccess (Static c) f
         return (JClass ret_c, L loc $ JField (Static c) f (JClass ret_c))
         -- if ret_c == "char"
         --    then return (JType (JPrim ret_c), JField (Static c) f ret_c)
         --    else return (JType (JClass ret_c), JField (Static c) f ret_c)
    NonStatic e ->
      do (t, e') <- inferExpr e
         case t of
           JClass c ->
             do ret_c   <- checkFieldAccess (NonStatic c) f
                return (JClass ret_c, JField (NonStatic e') f (JClass ret_c) `withLoc` e')
                -- if ret_c == "char"
                --   then return (JType (JPrim "char"), JField (NonStatic e') f ret_c)
                --   else return (JType (JClass ret_c), JField (NonStatic e') f ret_c)
           _ -> throwError (NotMember f t `withLoc` this) -- TODO: should be f's loc

inferExpr (L loc (Seq es)) =
  do (ts, es') <- mapAndUnzipM inferExpr es
     return (last ts, Seq es' `withLocs` es')

inferExpr this@(L loc (Merge e1 e2)) =
 do (t1, e1') <- inferExpr e1
    (t2, e2') <- inferExpr e2
    typeContext <- getTypeContext
    if disjoint typeContext t1 t2
       then return (And t1 t2, Merge e1' e2' `withLoc` e1')
       else throwError (General
                 (text "The merge of two terms of types" <+>
                 code (pretty t1) <+> text "and" <+> code (pretty t2) <+>
                 text "is overlapping") `withLoc` this)

inferExpr (L loc (RecordCon fs)) =
  do checkDupNames (map fst fs)
       -- TODO: This will give imprecise error message: should be "label", not "param".
     (ts, es') <- mapAndUnzipM inferExpr (map snd fs)
     let fs' = zip (map fst fs) ts
     return (foldl (\acc (l,t) -> And acc (RecordType [(l,t)])) (RecordType [head fs']) (tail fs'), L loc $ RecordCon (zip (map fst fs) es'))

inferExpr this@(L _ (RecordProj e l)) =
  do (t, e') <- inferExpr e
     case Map.lookup l (recordFields t) of
       Just t1 -> return (t1, RecordProj e' l `withLoc` this)
       Nothing -> throwError (NotMember l t `withLoc` this) -- TODO: should be l's loc

inferExpr (L loc (RecordUpdate e fs)) =
  do (_, es') <- mapAndUnzipM inferExpr (map snd fs)
     (t, e')  <- inferExpr e
     return (t, L loc $ RecordUpdate e' (zip (map fst fs) es'))

-- Well, I know the desugaring is too early to happen here...
-- inferExpr (L loc (LetModule (Module m binds) e)) =
--   do let fs = map bindName binds
--      let letrec = L loc $ Let Rec binds (L loc $ RecordCon (map (\f -> (f, noLoc $ Var f)) fs))
--      inferExpr (L loc $ Let NonRec [Bind m [] [] letrec Nothing] e)
-- inferExpr (L loc (ModuleAccess m f)) = inferExpr (L loc $ RecordProj (L loc $ Var m) f)

inferExpr this@(L _ (Type typeBind e))
  = do checkDupNames params
       typeContext <- getTypeContext
       maybe_kind <- liftIO $ kind typeContext pulledRight
       case maybe_kind of
         Nothing -> throwError (NotWellKinded pulledRight `withLoc` this) -- FIXME
         Just k  -> withTypeSynonym [(name, pulledRight, k)] $ inferExpr e
  where
    pulledRight = pullRight params rhs

    params = typeBindParams typeBind
    name   = typeBindName typeBind
    rhs    = typeBindRhs typeBind

inferExpr (L loc (Error ty str)) = do
       d <- getTypeContext
       let ty' = expandType d ty
       (_, e) <- inferAgainst str (JClass "java.lang.String")
       return (ty', L loc $ Error ty' e)

-- data List A = Nil | Cons A (List A) and ...; e
-- gamma |- Nil: \/A. List A, Cons: \/A. A List A
-- delta |- List: \A. List A
inferExpr (L loc (Data recflag databinds e)) =
    do checkDupNames [ name | DataBind name _ _ <- databinds]
       mapM_ checkDupNames [ name:params | DataBind name params _ <- databinds]
       mapM_ checkDupNames [ map constrName cs | DataBind _ _ cs <- databinds]
       case recflag of
           -- datatype are new type synonym in context
           -- constructors are new var in context
           -- use new context to check expression `e`
           NonRec -> do
               binds <- mapM nonrecDatabind databinds
               let (tvars, vars, databinds') = unzip3 binds
               (t, e') <- withTypeSynonym tvars $ withLocalVars (concat vars) $ inferExpr e
               return (t, L loc $ Data recflag databinds' e')
           Rec -> do
               let tvars = map getDatatype databinds
               withTypeSynonym tvars $ do
                   (vars, databinds') <- mapAndUnzipM recDatabind databinds
                   (t ,e') <- withLocalVars (concat vars) (inferExpr e)
                   return (t, L loc $ Data recflag databinds' e')
    where nonrecDatabind bind@(DataBind name params _) =
               do let tvars = getDatatype bind
                  (cons, vars) <- withTypeSynonym [tvars] $ withLocalTVars (zip params (repeat Star)) $ getConstrbinds bind
                  return (tvars, vars, DataBind name params cons)
          recDatabind bind@(DataBind name params _) =
               do (cons, vars)<- withLocalTVars (zip params (repeat Star)) $ getConstrbinds bind
                  return (vars, DataBind name params cons)

          getDatatype (DataBind name params cs) = (name, ty, kind)
               where ty = pullRight params (Datatype name (map TVar params) (map constrName cs))
                     kind = foldr (\_ acc -> KArrow Star acc) Star params
          getConstrbinds (DataBind name params cs) =
               do type_ctxt <- getTypeContext
                  let dt = Datatype name (map TVar params) (map constrName cs)
                      vars = [(nam, pullRightForall params $ wrap Fun [expandType type_ctxt t | t <- ts] dt) | Constructor nam ts <- cs]
                      cons = [Constructor nam (map (expandType type_ctxt) ts ++ [dt]) | (Constructor nam ts) <- cs]
                  return (cons, vars)

inferExpr this@(L loc (ConstrIn name)) =
    do result <- lookupVar name
       case result of
         Just t  -> return (t, L loc $ ConstrOut (Constructor name [t]) []) -- the last type will always be the real type
         Nothing -> throwError (NotInScope name `withLoc` this)

inferExpr this@(L loc (PolyList es)) =
 do (ts, _) <- mapAndUnzipM inferExpr es
    d <- getTypeContext
    let t = head ts
    case findIndex (not . compatible d t) ts of
        Just i -> throwError (TypeMismatch t (ts !! i) `withLoc` this) -- FIXME
        Nothing -> let es' = map (L loc . App (L loc $ TApp (L loc . ConstrIn $ "Cons") t)) es
                       desugares = foldr (\e acc -> L loc $ App e acc) (L loc $ TApp (L loc $ ConstrIn "Nil") t) es'
                   in inferExpr desugares

inferExpr expr@(L loc (Case e alts)) =
 do
   (t, e') <- inferExpr e
   if not (isDatatype t)
    then if (== JClass "java.lang.String") t
           then inferString
           else throwError (TypeMismatch t (Datatype "Datatype" [] []) `withLoc` expr)
    else do let (pats, exps) = unzip [(pat, exp) | ConstrAlt pat exp <- alts]
            -- check patterns
            pats' <- mapM (checkPattern t) pats

            -- check each branch: no duplicate names; check expr
            let alts' = zipWith (\(ConstrAlt _ exp') p -> ConstrAlt p exp') alts pats'
            (ts, es) <- mapAndUnzipM checkBranch alts'

            -- result type check: case branches have same type
            let resType = head ts
            type_ctxt <- getTypeContext
            let i = findIndex (not . compatible type_ctxt resType) ts
            when (isJust i) $ throwError (TypeMismatch resType (ts !! fromJust i) `withLoc` expr)

            -- pattern exhaustive test
            let patmatrix = map (: []) pats'
            value_ctxt <- getValueContext
            let exhaust = exhaustiveTest value_ctxt patmatrix 1
            unless (null exhaust) $ throwError $
               General (text "patterns are not exhausive, missing patterns:" <$> vcat (map (hcat . map pretty) exhaust))
               `withLoc` expr

            -- pattern overlap test
            let overlap = map (pats' !! ) . filter (\i -> not $ usefulClause (take i patmatrix) (patmatrix !! i)) $ [1.. length patmatrix -1]
            unless (null overlap) $
              throwError $ General (text "patterns are overlapped:"<$> vcat (map pretty overlap))
               `withLoc` expr

            return (resType, L loc $ Case e' (zipWith (\(ConstrAlt c _) -> ConstrAlt c) alts' es))

  where isDatatype (Datatype{}) = True
        isDatatype _ = False

        checkBranch (ConstrAlt pat e2) = do
            let getLocalVars PWildcard  = []
                getLocalVars (PVar nam ty) = [(nam, ty)]
                getLocalVars (PConstr _ pats) = concatMap getLocalVars pats
            let newvars = getLocalVars pat
            checkDupNames . fst . unzip $ newvars
            withLocalVars newvars (inferExpr e2)

        checkPattern ty (PVar nam _) = return (PVar nam ty)
        checkPattern _  PWildcard    = return PWildcard
        checkPattern ty pctr@(PConstr (Constructor nam _) pats) = do
            -- datatype; constructor
            unless (isDatatype ty) (throwError (TypeMismatch ty (Datatype "Datatype" [] []) `withLoc` expr))
            result <- lookupVar nam
            unless (isJust result) (throwError (NotInScope nam `withLoc` expr))
            -- type check: ty is the expected type
            let constr = fromJust result
                Datatype _ feed _ = ty
                ts = unwrapFun (feedToForall constr feed)
            type_ctxt <- getTypeContext
            unless (compatible type_ctxt (last ts) ty) (throwError (TypeMismatch constr ty `withLoc` expr))
            -- constructor arguments
            let error_msg =  text "Constructor" <+> bquotes (text nam) <+> text "should have" <+> int (length ts -1) <+>
                        text "arguments, but has been given" <+> int (length pats) <+> text "in pattern" <+> pretty pctr
            unless (length ts - 1 == length pats) (throwError (General error_msg `withLoc` expr))
            subpat <- zipWithM checkPattern ts pats
            return (PConstr (Constructor nam ts) subpat)

        -- temporary hack: this is to deal with pattern match on String.
        -- inferString :: ParsedExpr -> Checker (Type, CheckedExpr)
        inferString =
          do
            (_, e') <- inferExpr e
            let empt = [ b1' | ConstrAlt (PConstr (Constructor "empty" _) []) b1' <-  alts]
            let cons = [ (sub1,sub2,b2') | ConstrAlt (PConstr (Constructor "cons" _) [sub1, sub2]) b2' <- alts]
            unless (length alts == 2 && length empt == 1 && length cons == 1) $
              throwError (L NoLoc (General (text "String should have two patterns [] and head:tail"))) -- FIXME

            let [b1]               = empt
                [(sub1, sub2, b2)] = cons
            unless (isWildcardOrVar sub1 && isWildcardOrVar sub2) $
              throwError (L NoLoc (General $ text "String should have two patterns [] and head:tail")) -- FIXME

            let localvar  = case sub1 of PVar nam _ -> [(nam, JClass "java.lang.Character")]
                                         _          -> []
                localvar' = case sub2 of PVar nam _ -> (nam, JClass "java.lang.String"):localvar
                                         _          -> []
            (t1, emptyexpr) <- inferExpr b1
            (_,  nonemptyexpr) <- withLocalVars localvar' $ inferAgainst b2 t1
            let emptyalt = ConstrAlt (PConstr (Constructor "empty" []) []) emptyexpr
                nonemptyalt = ConstrAlt (PConstr (Constructor "cons" []) [sub1, sub2]) nonemptyexpr
            return (t1, CaseString e' [emptyalt, nonemptyalt] `withLoc` e)

-- | "Pull" the type params at the LHS of the equal sign to the right.
-- A (high-level) example:
--   A B t  ->  \A. \B. t
-- Another concrete example:
--   ghci> pullRight ["A", "B"] (JClass "java.lang.Integer")
--   OpAbs "A" (OpAbs "B" (JClass "java.lang.Integer"))
pullRight :: [Name] -> Type -> Type
pullRight params t = foldr OpAbs t params

pullRightForall :: [Name] -> Type -> Type
pullRightForall params t = foldr (\a -> Forall (a,Nothing)) t params

inferAgainst :: ParsedExpr -> Type -> Checker (Type, CheckedExpr)
inferAgainst expr expected_ty
  = do (found_ty, expr') <- inferExpr expr
       d <- getTypeContext
       if compatible d found_ty expected_ty
          then return (found_ty, expr')
          else throwError (TypeMismatch expected_ty found_ty `withLoc` expr)

inferAgainstAnyJClass :: ParsedExpr -> Checker (ClassName, CheckedExpr)
inferAgainstAnyJClass expr
  = do (ty, expr') <- inferExpr expr
       case ty of
        -- JType (JPrim "char") -> return ("java.lang.Character", expr')
        JClass c -> return (c, expr')
        _ -> throwError (L NoLoc (TypeMismatch ty (JClass "<any Java class>"))) -- FIXME

-- | Check "f [A1,...,An] (x1:t1) ... (xn:tn): t = e"
normalizeBind :: ReadBind -> Checker CheckedBind
normalizeBind bind
  = do bind' <- checkBindLHS bind
       (bindRhsTy, bindRhs') <- withLocalConstrainedTVars (bindTyParams bind') $ -- TODO: Issue: #addconstrainttocontext
                                  do expandedBindArgs <- mapM (\(L _ x,t) -> do { d <- getTypeContext; return (x,expandType d t) }) (bindParams bind')
                                     withLocalVars expandedBindArgs (inferExpr (bindRhs bind'))
       case bindRhsTyAscription bind' of
         Nothing -> return ( bindName bind'
                           , wrap Forall (bindTyParams bind') (wrap Fun (map snd (bindParams bind')) bindRhsTy)
                           , wrap (\x acc -> BLam x acc `withLoc` acc) (bindTyParams bind') (wrap (\x acc -> Lam x acc `withLoc` acc) (bindParams bind') bindRhs'))
         Just ty_ascription ->
           withLocalConstrainedTVars (bindTyParams bind') $ -- TODO: Issue: #addconstrainttocontext
             do checkType ty_ascription
                d <- getTypeContext
                let ty_ascription' = expandType d ty_ascription
                if compatible d ty_ascription' bindRhsTy
                   then return (bindName bind'
                               , wrap Forall (bindTyParams bind') (wrap Fun (map snd (bindParams bind')) bindRhsTy)
                               , wrap (\x acc -> BLam x acc `withLoc` acc) (bindTyParams bind') (wrap (\x acc -> Lam x acc `withLoc` acc) (bindParams bind') bindRhs'))
                   else throwError (L NoLoc (TypeMismatch (expandType d ty_ascription') bindRhsTy)) -- FIXME

-- | Check the LHS to the "=" sign of a bind, i.e., "f A1 ... An (x1:t1) ... (xn:tn)".
-- First make sure the names of type params and those of value params are distinct, respectively.
-- Then check and expand the types of value params.
checkBindLHS :: ReadBind -> Checker ReadBind
checkBindLHS Bind{..}
  = do checkDupNames (map fst bindTyParams)
       checkDupNames (map (unLoc . fst) bindParams)
       bindParams' <- withLocalConstrainedTVars bindTyParams $ -- TODO: Issue: #addconstrainttocontext
                    -- Restriction: type params have kind *
                    do d <- getTypeContext
                       forM bindParams (\(x,t) ->
                         do checkType t
                            return (x, expandType d t))
       return Bind { bindParams = bindParams', .. }

collectBindIdSigs :: [ReadBind] -> Checker [(Name, Type)]
collectBindIdSigs
  = mapM (\ Bind{..} ->
            case bindRhsTyAscription of
              Nothing    -> throwError (L NoLoc (MissingTyAscription bindName)) -- FIXME
              Just tyAscription ->
                do d <- getTypeContext
                   let d' = foldr (\(a,_) acc -> addTVarToContext [(a, Star)] acc) d bindTyParams -- TODO: Issue: #addconstrainttocontext
                   return (bindName,
                           wrap Forall bindTyParams $
                           wrap Fun [expandType d' ty |  (_,ty) <- bindParams] $
                           expandType d' tyAscription))

-- | Normalize later bindings with typing contexts augmented with
-- previous bindings
normalizeBindAndAccum :: [ReadModuleBind] -> Checker [Definition]
normalizeBindAndAccum = normalize []
  where
    normalize :: [Definition]
              -> [ReadModuleBind]
              -> Checker [Definition]
    normalize binds [] = return (reverse binds)
    normalize binds (b:bs) = do
      let env = concatMap getEnv binds
      binds' <- case b of
                  BindNonRec b -> withLocalVars env (fmap Def (normalizeBind b))
                  BindRec bb -> do
                    sigs <- collectBindIdSigs bb
                    withLocalVars (env ++ sigs) (fmap DefRec (mapM normalizeBind bb))
      normalize (binds' : binds) bs
    getEnv :: Definition -> [(Name, Type)]
    getEnv (Def (a, b, c)) = [(a, b)]
    getEnv (DefRec bs) = map (\(a, b, c) -> (a, b)) bs

-- | Check that a type has kind *.
checkType :: Type -> Checker ()
checkType t =
  case t of
    And t1 t2 -> do
      checkType t1
      checkType t2
      ctxt <- getTypeContext
      unless (disjoint ctxt t1 t2) $
        throwError (L NoLoc (General (text "intersection of types is not disjoint"))) -- FIXME
    JClass c -> checkClassName c
    _ -> do
      delta <- getTypeContext
      maybe_kind <- liftIO $ kind delta t
      case maybe_kind of
        Nothing   -> throwError (L NoLoc (NotWellKinded t)) -- FIXME
        Just Star -> return ()
        Just k    -> throwError (L NoLoc (KindMismatch Star k t)) -- FIXME

unlessIO :: (Monad m, MonadIO m) => IO Bool -> m () -> m ()
unlessIO test do_this
  = do ok <- liftIO test
       unless ok do_this

-- Client library of typeserver API

checkClassName :: ClassName -> Checker ()
checkClassName c
  = do memoized_java_classes <- getMemoizedJavaClasses
       unless (c `Set.member` memoized_java_classes) $
         do conn <- getTypeServer
            res <- liftIO (JvmTypeQuery.definedClass conn c)
            if res
               then memoizeJavaClass c
               else throwError (L NoLoc (NoSuchClass c)) -- FIXME

checkConstruction :: ClassName -> [ClassName] -> Checker ()
checkConstruction c args
  = do conn <- getTypeServer
       unlessIO (JvmTypeQuery.definedConstructor conn c args) $
         throwError (L NoLoc (NoSuchConstructor c args)) -- FIXME

checkMethodCall :: JReceiver ClassName -> MethodName -> [ClassName] -> Checker ClassName
checkMethodCall receiver m args
  = do conn <- getTypeServer
       res <- liftIO (JvmTypeQuery.findMethodReturnType conn c (is_static, m) args)
       case res of
         Nothing           -> throwError (L NoLoc (NoSuchMethod receiver m args)) -- FIXME: Should be the location of the method name
         Just return_class -> return return_class
    where
       (is_static, c) = unwrapJReceiver receiver

checkFieldAccess :: JReceiver ClassName -> FieldName -> Checker ClassName
checkFieldAccess receiver f
  = do conn <- getTypeServer
       res <- liftIO (JvmTypeQuery.findFieldType conn c (is_static, f))
       case res of
         Nothing           -> throwError (L NoLoc (NoSuchField receiver f)) -- FIXME: Should be the location of the field name
         Just return_class -> return return_class
    where
       (is_static, c) = unwrapJReceiver receiver

checkModuleFunction :: PoorMensImport ModuleName -> Checker [(Name, ModuleMapInfo)]
checkModuleFunction (PoorMensImport m) =
  do
    typeserver <- getTypeServer
    res <- liftIO (JvmTypeQuery.extractModuleInfo typeserver (pName, moduleName))
    case res of
      Nothing  -> throwError (L NoLoc (ImportFail m)) -- FIXME: Should be the location of the module path
      Just ret -> return (map flatInfo (fst ret))

  where
    (packageName, moduleName) =
      let w = splitOn "." m
      in (intercalate "." (init w), last w)
    pName = if null packageName then Nothing else Just packageName
    flatInfo (JvmTypeQuery.ModuleInfo f g t) = (f, (pName, t, g, capitalize moduleName))

unwrapJReceiver :: JReceiver ClassName -> (Bool, ClassName)
unwrapJReceiver (NonStatic c) = (False, c)
unwrapJReceiver (Static    c) = (True, c)

srcLitType :: Lit -> Type
srcLitType (Int _)    = JClass "java.lang.Integer"
srcLitType (String _) = JClass "java.lang.String"
srcLitType (Bool _)   = JClass "java.lang.Boolean"
srcLitType (Char _)   = JClass "java.lang.Character"
srcLitType UnitLit    = Unit

checkDupNames :: [Name] -> Checker ()
checkDupNames names
  = case findOneDup names of
      Nothing   -> return ()
      Just name -> throwError (L NoLoc (DuplicateParam name))
                  -- FIXME: Should be the locations of the conflicting names

-- | Find one instance of duplicate in a list.
findOneDup :: Ord a => [a] -> Maybe a
findOneDup xs = go xs Set.empty
  where
    go []      _ = Nothing
    go (x:xs') s = if Set.member x s
                     then Just x
                     else go xs' (Set.insert x s)

unwrapFun :: Type -> [Type]
unwrapFun (Fun t t') = t : unwrapFun t'
unwrapFun t = [t]

feedToForall :: Type -> [Type] -> Type
feedToForall =
    foldl (\t t_feed -> case t of
                          Forall (a,_) t' -> fsubstTT (a, t_feed) t'
                          _ -> prettySorry "TypeCheck.feedToForall" (pretty t))

---- find the arity of a constructor
ctrArity :: Map.Map Name Type -> Name -> Int
ctrArity value_ctxt name =
    length (removeForall t) - 1
    where Just t =  lookupVarType name value_ctxt
          removeForall (Forall _ b) = removeForall b
          removeForall x            = unwrapFun x

-- Useful clause detect
-- whether clause q is useful with respect to matrix P
usefulClause :: [[Pattern]] -> [Pattern] -> Bool

---- base case
usefulClause [] _ = True
usefulClause _ [] = False

---- q begins with a constructor c
---- U (P, q) = U (S(c,P), S(c,q))
usefulClause pats clause@(PConstr ctr _:_) =
    usefulClause (specializedMatrix ctr pats)
                 (head (specializedMatrix ctr [clause]))

---- q begins with a wildcard(or a variable)
usefulClause pats clause =
    -- P has some missing constructor
    -- U (P, _:rest) = U (D(p), rest))
    if all isWildcardOrVar patshead || missingconstrs /= []
    then usefulClause (defaultMatrix pats) (tail clause)
    -- P has all constructors appeared
    -- U (P, q) = whether exists a constructor c that U (S(c,P), S(c,q)) is true
    else any (\ctr -> usefulClause (specializedMatrix ctr pats)
                                   (head (specializedMatrix ctr [clause])))
             appearconstrs
    where patshead = map head pats
          (appearconstrs, missingconstrs) = constrInfo patshead

-- Test a Pattern matrix is exhaustive
exhaustiveTest :: Map.Map Name Type -> [[Pattern]] -> Int -> [[Pattern]]

---- basic cases
exhaustiveTest _ [] 0 = [[]]
exhaustiveTest _ _  0 = []

exhaustiveTest value_ctxt pats n
    -- Simga is the set of appearing constructors
    -- Sigma is empty
    -- if I(D(p), n-1) returns (p2,...,pn)
    -- I(P, n) = (_, p2,...,pn)
    | all isWildcardOrVar patshead = map (PWildcard :) $ exhaustiveTest value_ctxt (map tail pats) (n-1)
    | null missingconstrs          = exhaustivityForCtr
    | otherwise                    = exhaustivityForCtr ++ exhaustivityForWildcard
    -- if I(S(c, P), a+n-1) returns (r1,...,ra, p2,...,pn)
    -- I(P, n) = (c(r1,...ra), p2,...,pn)
    where patshead = map head pats
          (appearconstrs, missingconstrs) = constrInfo patshead
          exhaustivityForCtr =
                 [ PConstr ctr component: eachres' |
                         ctr <- appearconstrs,
                         let arity = length (constrParams ctr) - 1,
                         eachres <- exhaustiveTest value_ctxt (specializedMatrix ctr pats) (arity + n - 1),
                         let (component, eachres') = splitAt arity eachres ]
    -- Sigma is incomplete
    -- if I(D(P), n-1) returns (p2,...,pn)
    -- I(P, n) = (c(_,...,_), p2,...,pn) for each missing constructor c
          exhaustivityForWildcard =
                 [ cur: eachres | eachres <- exhaustiveTest value_ctxt (defaultMatrix pats) (n-1),
                                  name <- missingconstrs,
                                  let arity = ctrArity value_ctxt name,
                                  let cur = PConstr (Constructor name []) $ replicate arity PWildcard ]


<|start_filename|>runtime/src/f2j/Closure.java<|end_filename|>
package f2j;

public abstract class Closure
{
  public Object arg;
  public Object res;
  public boolean hasApply = true;
  public abstract void apply ();
  public Closure clone () {
      return (Closure) ((Object) this.clone());
  }
}


<|start_filename|>repl/Main.hs<|end_filename|>
module Main where


import           Control.Monad
import           Control.Monad.IO.Class
import           FileIO (TransMethod (Naive))
import           RuntimeProcessManager (withRuntimeProcess)
import           System.Console.Haskeline (runInputT, defaultSettings)
import           System.Directory (doesFileExist)
import           System.IO
import qualified Data.Map as Map

-- REPL-specific modules
import           BackEnd
import           Loop
import qualified Environment as Env
import qualified History as Hist

main :: IO ()
main = do
  withRuntimeProcess "FileServer" LineBuffering
       (\(inP,outP) ->
        do liftIO printHelp
           runInputT defaultSettings
                         (Loop.loop (inP, outP) (0, compileN, [Naive])
                          Map.empty Env.empty Hist.empty Hist.empty 0 False False False False 0))

fileExist :: String -> IO ()
fileExist name = do
        exist <- doesFileExist name
        unless exist $ fileExist name

printFile :: IO ()
printFile = do
        f <- getLine
        contents <- readFile f
        putStr contents


<|start_filename|>frontend/simplify/Simplify.hs<|end_filename|>
{-# LANGUAGE TypeOperators, FlexibleInstances, MultiParamTypeClasses, RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}
{- |
Module      :  Simplify
Description :  The simplifier turns SystemFI into Core.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>, <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable

The simplifier translates System F with intersection types to vanilla System F.
-}

module Simplify
  ( simplify
  , simplify'
  ) where

import qualified SimplifyImpl         as Impl

import Core
import qualified SystemFI             as FI

import Unsafe.Coerce (unsafeCoerce)

simplify :: FI.FExp -> Expr t e
simplify = Impl.simplify

simplify' :: FI.Expr t e -> Expr t e
simplify' = Impl.dedeBruE 0 [] 0 [] . Impl.transExpr 0 0 . unsafeCoerce


<|start_filename|>runtime/src/f2j/tuples/Tuple4.java<|end_filename|>
package f2j.tuples;

public class Tuple4 {
    public final Object _1, _2, _3, _4;

    public Tuple4(Object _1, Object _2, Object _3, Object _4) {
        this._1 = _1;
        this._2 = _2;
        this._3 = _3;
        this._4 = _4;
    }
}


<|start_filename|>frontend/abstractsyntax/SrcLoc.hs<|end_filename|>
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}

{- |
Module      :  SrcLoc
Description :  This module contains types and utility functions for tagging things with locations
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module SrcLoc where

import Text.PrettyPrint.ANSI.Leijen

type Located a = GenLocated Loc a

data GenLocated l e = L l e
                      deriving (Eq, Ord, Show) -- Typeable, Data)

instance Functor (GenLocated l) where
  fmap f (L l e) = L l (f e)

deriving instance Foldable    (GenLocated l)
deriving instance Traversable (GenLocated l)

data Loc = Loc { line :: !Int, column :: !Int }
         | NoLoc
           deriving (Eq, Ord, Show)

instance Pretty Loc where
    pretty (Loc l c) = int l <> colon <> int c <> colon
    pretty NoLoc = empty

unLoc :: Located a -> a
unLoc (L _ x) = x

withLoc :: b -> Located a -> Located b
x `withLoc` (L loc _) = L loc x

noLoc :: a -> Located a
noLoc = L NoLoc

withLocs :: b -> [Located a] -> Located b
withLocs x [] = noLoc x
withLocs x (l:_) = x `withLoc` l


<|start_filename|>frontend/typecheck/TypeErrors.hs<|end_filename|>
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

module TypeErrors where

import JavaUtils
import PrettyUtils
import Src

import Prelude hiding ((<$>))
import Text.PrettyPrint.ANSI.Leijen

data TypeError
  = General Doc
  | DuplicateParam Name
  | ExpectJClass
  | TypeMismatch Type Type
  | KindMismatch Kind Kind Type
  | MissingTyAscription Name
  | NotInScope Name
  | NotWellKinded Type
  | NotMember Name Type
  | NotAFunction Type

  -- Java-specific type errors
  | NoSuchClass       ClassName
  | NoSuchConstructor ClassName [ClassName]
  | NoSuchMethod      (JReceiver ClassName) MethodName [ClassName]
  | NoSuchField       (JReceiver ClassName) FieldName
  | ImportFail        ModuleName
  deriving (Show)

instance Pretty TypeError where
  pretty (General doc)      = doc
  pretty (NotInScope x)  = code (text x) <+> text "is not in scope"
  pretty (DuplicateParam ident) = text "duplicate parameter" <+> code (text ident)
  pretty (NotWellKinded t)  = code (pretty t) <+> text "is not well-kinded"
  pretty (KindMismatch expected found t) =
    text "kind mismatch" <> colon <$>
    indent 2 (text "expected" <+> code (pretty expected) <> comma <$>
              text "   found" <+> code (pretty found)) <$>
    text "in the type" <> colon <+> pretty t

  pretty (TypeMismatch expected found) =
    text "type mismatch" <> colon <$>
    indent 2 (text "expected" <+> code (pretty expected) <> comma <$>
              text "   found" <+> code (pretty found))
  pretty (NoSuchClass c)  = text "no such class:" <+> code (text c)
  pretty (NotMember x t)  = code (text x) <+> text "is not a member of the type" <+> code (pretty t)
  pretty (NotAFunction t) = code (pretty t) <+> text "is not a function; it cannot be applied"

  -- Java-specific type errors
  pretty (NoSuchMethod (NonStatic c) m cs) =
    text "no such method" <+> code (text m) <+>
    text "on" <+> code (pretty (JClass c)) <+>
    text "with parameters of type" <+> commas (map (code . pretty . JClass) cs)
  pretty (NoSuchMethod (Static c) m cs) =
    text "no such static method" <+> code (text m) <+>
    text "on" <+> code (pretty (JClass c)) <+>
    text "with parameters of type" <+> commas (map (code . pretty . JClass) cs)

  pretty (NoSuchField (NonStatic c) f) =
    text "no such field" <+> code (text f) <+>
    text "on" <+> code (pretty (JClass c))
  pretty (NoSuchField (Static c) f) =
    text "no such static field" <+> code (text f) <+>
    text "on" <+> code (pretty (JClass c))

  pretty (MissingTyAscription ident) =
    text "recursive definition" <+> code (text ident) <+>
    text "needs type ascription for the right-hand side"

  pretty e = text (show e)


<|start_filename|>runtime/src/f2j/unbox/Closure.java<|end_filename|>
package f2j.unbox;

public interface Closure {
    void apply();
}


<|start_filename|>frontend/Mini.hs<|end_filename|>
{-# LANGUAGE RankNTypes #-}

module Mini where

data Type t = Int | TVar t | Fun (Type t) (Type t) | Forall (t -> Type t)

newtype CType = CType { unCType :: forall t. Type t }

konstTy = Forall (\a -> Forall (\b -> Fun (TVar a) (Fun (TVar b) (TVar a))))

t1 = let Forall f = konstTy in Forall (\a -> subst' a Int (f a))

t2 = let Forall f = konstTy in join (f Int)

dedeBruijnType :: Int -> Int -> [t] -> Type Int -> Type t
dedeBruijnType s _ as (TVar i)    = TVar (reverse as !! (i-s))
dedeBruijnType s _ _  Int         = Int
dedeBruijnType s i as (Fun t1 t2) = Fun (dedeBruijnType s i as t1) (dedeBruijnType s i as t2)
dedeBruijnType s i as (Forall f)  = Forall (\a -> dedeBruijnType s (i+1) (a:as) (f i))

subst' :: Int -> Type Int -> Type Int -> Type Int
subst' x r Int         = Int
subst' x r (TVar a)
  | a == x            = r
  | otherwise         = TVar a
subst' x r (Fun t1 t2) = Fun (subst' x r t1) (subst' x r t2)
subst' x r (Forall f)  = Forall (\a -> subst' x r (f a))

-- subst :: Type Int -> Type Int -> Type t
-- subst t1 t2 = dedeBruijnType subst' 0 t1 t2

pretty :: Int -> Type Int -> String
pretty _ Int         = "Int"
pretty _ (TVar a)    = "a" ++ show a
pretty i (Fun t1 t2) = "(" ++ pretty i t1 ++ " -> " ++ pretty i t2 ++ ")"
pretty i (Forall f)  = "forall a" ++ show i ++ ". " ++ pretty (i+1) (f i)

join :: Type (Type t) -> Type t
join Int         = Int
join (TVar a)    = a
join (Fun t1 t2) = Fun (join t1) (join t2)
join (Forall f)  = Forall (\a -> join (f (TVar a)))


<|start_filename|>frontend/StaticAssert.hs<|end_filename|>
module StaticAssert (staticAssert) where

import Control.Monad        (unless)
import Language.Haskell.TH  (Q, reportError)

-- http://stackoverflow.com/questions/6648764/compile-time-assertions-with-ghc-haskell

staticAssert :: String -> Bool -> Q [a]
staticAssert msg cond = do
  unless cond (reportError ("Compile time assertion failed: " ++ msg))
  return []


<|start_filename|>examples/fractals/Makefile<|end_filename|>
all : fractals.sf
	cd lib; javac *.java
	f2j -r -m stack -m apply $^

.PHONY : clean
clean :
	rm -f lib/*.class *.class *.java


<|start_filename|>runtime/src/f2j/TypeServer.java<|end_filename|>
package f2j;

import java.lang.annotation.Annotation;
import java.lang.reflect.Constructor;
import java.lang.reflect.Field;
import java.lang.reflect.Method;
import java.lang.reflect.Modifier;
import java.util.*;
import java.util.stream.Collectors;


public class TypeServer {

  private final static Map<Class<?>, Class<?>> map = new HashMap<Class<?>, Class<?>>();
  private final static Map<String, Class<?>> arrayMap = new HashMap<String, Class<?>>();

  static {
    map.put(boolean.class, Boolean.class);
    map.put(byte.class, Byte.class);
    map.put(short.class, Short.class);
    map.put(char.class, Character.class);
    map.put(int.class, Integer.class);
    map.put(long.class, Long.class);
    map.put(float.class, Float.class);
    map.put(double.class, Double.class);
    map.put(void.class, Void.class);
  }

  static {
    arrayMap.put("char[]", char[].class);
    arrayMap.put("int[]", int[].class);
    arrayMap.put("byte[]", byte[].class);
    arrayMap.put("boolean[]", boolean[].class);
    arrayMap.put("long[]", long[].class);
    arrayMap.put("double[]", double[].class);
  }

  public static void main(String[] args) {
    Scanner inp = new Scanner(System.in);
    while (true) {
      if (!inp.hasNextLine()) continue;
      String line = inp.nextLine();
      String[] words = line.split(" ");
      Object result = false;
      switch (words[0]) {
      case "qType":
        result = queryType(words[1]);
        break;
      case "qConstructor":
        result = queryNew(words[1], Arrays.copyOfRange(words, 2, words.length));
        break;
      case "qMethod":
        result = queryMethod(words[1], words[2], Arrays.copyOfRange(words, 3, words.length), false);
        break;
      case "qStaticMethod":
        result = queryMethod(words[1], words[2], Arrays.copyOfRange(words, 3, words.length), true);
        break;
      case "qField":
        result = queryField(words[1], words[2], false);
        break;
      case "qStaticField":
        result = queryField(words[1], words[2], true);
        break;
      case "qModuleInfo":
        result = queryModule(words[1]);
        break;
      default:
        System.err.println("######## BAD QUERY ########");
        break;
      }
      System.out.println(result.toString());
    }
  }

  public static boolean queryType(String classFullName) {
    try {
      Class.forName(classFullName);
    } catch (ClassNotFoundException e) {
      return false;
    }
    return true;
  }


  public static boolean queryNew(String classFullName, String... constructorArgs) {
    try {
      Class<?> c = Class.forName(classFullName);
      Constructor<?>[] cList = c.getConstructors();
      Class<?>[] givenClasses = getClassArray(constructorArgs);

      for (Constructor cs : cList) {
        Class<?>[] actualClasses = cs.getParameterTypes();
        if (isArrayAssignableFrom(actualClasses, givenClasses))
          return true;
      }
      return false;
    } catch (Exception e) {
      return false;
    }
  }


  public static String queryMethod(String classFullName, String methodName, String[] methodArgs, boolean stat) {
    try {
      Class<?> c = Class.forName(classFullName);
      Class<?>[] givenClasses = getClassArray(methodArgs);
      Method[] mList = c.getMethods();

      List<Class<?>> ms = Arrays.stream(mList).filter(m -> {
          Class<?>[] actualClasses = m.getParameterTypes();
          return Modifier.isStatic(m.getModifiers()) == stat
          && m.getName().equals(methodName)
          && isArrayAssignableFrom(actualClasses, givenClasses);
        }).map(Method::getReturnType).sorted((m1, m2) -> m1.isAssignableFrom(m2) ? 1 : -1).collect(Collectors.toList());

      if (ms.size() == 0) return "$";
      else return classFix(ms.get(0)).getCanonicalName();
    } catch (Exception e) {
      return "$";
    }
  }


  public static String queryField(String classFullName, String fieldName, boolean stat) {
    try {
      Class<?> c = Class.forName(classFullName);
      Field f = c.getField(fieldName);
      if (Modifier.isStatic(f.getModifiers()) == stat)
        return classFix(f.getType()).getCanonicalName();
      else
        return "$";
    } catch (Exception e) {
      return "$";
    }
  }

  public static String queryModule(String moduleName) {
    try {
      StringBuffer result = new StringBuffer();
      ClassLoader classLoader = ClassLoader.getSystemClassLoader();
      Class m = classLoader.loadClass(moduleName + "$");
      Field[] fields = m.getDeclaredFields();
      for (Field field : fields) {
        ModuleFunction f = (ModuleFunction) field.getAnnotation(ModuleFunction.class);
        if (f != null) {
          result.append(f.name() + "$" + f.gname() + "$" + f.signature() + "$");
        }
      }
      return result.toString();
    } catch (Exception e) {
      return "$";
    }
  }

  private static Class<?>[] getClassArray(String[] names) throws ClassNotFoundException {

    Class<?>[] classes = new Class<?>[names.length];
    for (int i = 0; i < names.length; i++) {
      classes[i] = arrayMap.containsKey(names[i]) ? arrayMap.get(names[i]) : Class.forName(names[i]);
    }
    return classes;
  }

  // a -> super; b -> sub
  private static boolean isArrayAssignableFrom(Class<?>[] a, Class<?>[] b) {
    if (a.length != b.length) return false;
    for (int i = 0; i < a.length; i++)
      if (!classFix(a[i]).isAssignableFrom(classFix(b[i])))
        return false;
    return true;
  }

  // int -> Integer
  private static Class<?> classFix(Class<?> c) {
    return c.isPrimitive() ? map.get(c) : c;
  }

}


<|start_filename|>Makefile<|end_filename|>
# General project-wide tasks

PARSERS_DIR := frontend/parse
TEST_DIR := testsuite
FLAGS := -m naive


all : compiler


# Must remove generated Lexer.hs and Parser.hs before `make`
# Otherwise Stack will choose, for example, Parser.hs instead of
# Parser.y, and Parser.hs can be outdated compared to Parser.y
.PHONY : compiler
compiler : clean_parsers runtime
	stack build --copy-bins

# .PHONY : smt
# smt : runtime dependencies
# 	$${CABAL=cabal}  install -f Z3

.PHONY : test
test : whitespace_test runtime
	stack build fcore --test

.PHONY : whitespace_test
whitespace_test :
	ruby $(TEST_DIR)/whitespace_check.rb

# .PHONY : dependencies
# dependencies :
# 	stack --no-terminal build --only-snapshot

.PHONY : runtime
runtime :
	cd runtime && ant

.PHONY : parsers
parsers :
	cd $(PARSERS_DIR) && make

.PHONY : clean_parsers
clean_parsers :
	cd $(PARSERS_DIR) && make clean

# .PHONY : guard
# guard :
# 	cabal install hspec
# 	gem install guard-haskell

.PHONY : clean
clean :
	rm -rf dist
	rm -f *.class *.jar Main.java
	rm -f $(TEST_DIR)/tests/run-pass/*.java
	stack clean
	cd $(PARSERS_DIR) && make clean
	cd runtime && ant clean


<|start_filename|>frontend/Assertions.hs<|end_filename|>
-- Static assertions that should hold at compile time.

{-# LANGUAGE TemplateHaskell #-}

module Assertions where

import StaticAssert

import qualified Src  as S
import qualified Core as C
import Simplify

import Data.Maybe

$(staticAssert "alphaEq implies subtype" (S.subtype (S.TVar "a" `S.And` S.TVar "b") (S.TVar "b" `S.And` S.TVar "a")))
$(staticAssert "alphaEq implies subtype" (subtype 0 (C.TVar "" 0 `C.And` C.TVar "" 1)   (C.TVar "" 1 `C.And` C.TVar "" 0)))
$(staticAssert "subtype implies coercion exists" (isJust (coerce 0 (C.TVar "" 0 `C.And` C.TVar "" 1) (C.TVar "" 1 `C.And` C.TVar "" 0))))


<|start_filename|>frontend/typecheck/Problem.hs<|end_filename|>
{-
The uniform container (with its pretty printer) for holding all kinds of problems,
including, but not limited to SyntaxErrors and TypeErrors, in user programs.
-}
module Problem
  ( Problem(..)
  , ProblemLevel(..)
  , prettyProblems
  ) where

import Text.PrettyPrint.ANSI.Leijen hiding (line, column)

data Problem = Problem
  { problemLevel    :: ProblemLevel
  , problemLocation :: (FilePath, Int, Int)
  , problemLine     :: String
  , problemDescription :: Doc
  }

data ProblemLevel = Error | Warning deriving (Eq, Show)

instance Pretty ProblemLevel where
  pretty Error   = dullred    (text "error")
  pretty Warning = dullyellow (text "warning")


prettyProblems :: [Problem] -> Doc
prettyProblems problems
  = vcat (map prettyProblem problems) <$$>
    int errorCount <+> text (pluralize "error" errorCount)
    <+> text "and" <+>
    int warningCount <+> text (pluralize "warning" warningCount)
    <+> text "found"
  where
    errorCount   = length $ filter (\p -> problemLevel p == Error) problems
    warningCount = length $ filter (\p -> problemLevel p == Warning) problems
    pluralize s n = if n > 1 then s ++ "s" else s

prettyProblem :: Problem -> Doc
prettyProblem problem
  = prettyLocation (problemLocation problem) <$$>
    problemLineWithCursor <$$>
    pretty (problemLevel problem) <> colon <+> problemDescription problem <> linebreak
  where
    problemLineWithCursor :: Doc
    problemLineWithCursor
      = text (problemLine problem) <$$>
        indent (let (_,_,column) = problemLocation problem in column - 1) (char '^')
    prettyLocation :: (FilePath, Int, Int) -> Doc
    prettyLocation (filePath, line, _column)
      = text "File" <+> dquotes (text filePath) <> comma <+> text "line" <+> int line

-- Test cases

testProblem1 :: Problem
testProblem1 = Problem
  { problemLevel    = Error
  , problemLocation = ("examples/foo.sf", 36, 15)
  , problemLine     = "        doc = Nokogiri::HTML(page.body, nil, @encoding)"
  , problemDescription = text "Undefined class: ‘Nokogiri’" }

testProblem2 :: Problem
testProblem2 = Problem
  { problemLevel    = Warning
  , problemLocation = ("problems.sf", 36, 22)
  , problemLine     = "    indent (let (_,_,column) = problemLocation problem in column - 1) (char '^')"
  , problemDescription = text "Undefined local variable or method `f' for main:Object (NameError)" }

main :: IO ()
main = print (prettyProblems [testProblem1, testProblem2])


<|start_filename|>testsuite/TransCFSpec.hs<|end_filename|>
module TransCFSpec (transSpec, testConcreteSyn) where

import BackEnd
import FrontEnd (source2core)
import JavaUtils (getClassPath)
import MonadLib
import OptiUtils (Exp(Hide))
import PartialEvaluator (rewriteAndEval)
import SpecHelper
import StringPrefixes (namespace)
import StringUtils (capitalize)
import TestTerms

import Language.Java.Pretty (prettyPrint)
import System.Directory
import System.FilePath
import System.IO
import System.Process
import Test.Tasty.Hspec


testCasesPath = "testsuite/tests/should_run"

fetchResult :: Handle -> IO String
fetchResult outP = do
  msg <- hGetLine outP
  if msg == "exit" then fetchResult outP else return msg

-- java compilation + run
compileAndRun inP outP name compileF exp =
  do let source = prettyPrint (fst (compileF name (rewriteAndEval exp)))
     let jname = name ++ ".java"
     hPutStrLn inP jname
     hPutStrLn inP (source ++ "\n" ++ "//end of file")
     fetchResult outP

testAbstractSyn inP outP compilation (name, filePath, ast, expectedOutput) = do
  let className = capitalize $ dropExtension (takeFileName filePath)
  output <- runIO (compileAndRun inP outP className compilation ast)
  it ("should compile and run " ++ name ++ " and get \"" ++ expectedOutput ++ "\"") $
     return output `shouldReturn` expectedOutput

testConcreteSyn inP outP compilation (name, filePath) =
  do source <- runIO (readFile filePath)
     case parseExpectedOutput source of
       Nothing -> error (filePath ++ ": " ++
                         "The integration test file should start with '-->', \
                         \followed by the expected output")
       Just expectedOutput ->
         do ast <- runIO (source2core NoDump (filePath, source))
            testAbstractSyn inP outP compilation (name, filePath, ast, expectedOutput)

abstractCases =
  [ ("factorial 10", "main_1", Hide factApp, "3628800")
  , ("fibonacci 10", "main_2", Hide fiboApp, "55")
  , ("idF Int 10", "main_3", Hide idfNum, "10")
  , ("const Int 10 20", "main_4", Hide constNum, "10")
  , ("program1 Int 5", "main_5", Hide program1Num, "5")
  , ("program2", "main_6", Hide program2, "5")
  , ("program4", "main_7", Hide program4, "11")
  ]

transSpec =
  do concreteCases <- runIO (discoverTestCases testCasesPath)

     -- change to testing directory for module testing
     curr <- runIO (getCurrentDirectory)
     runIO (setCurrentDirectory $ curr </> testCasesPath)

     forM_
       [("BaseTransCF" , compileN)
       ,("ApplyTransCF", compileAO)
       ,("StackTransCF", compileS)]
       (\(name, compilation) ->
         describe name $
           do cp <- runIO getClassPath
              let p = (proc "java" ["-cp", cp, namespace ++ "FileServer", cp])
                          {std_in = CreatePipe, std_out = CreatePipe}
              (Just inP, Just outP, _, proch) <- runIO $ createProcess p
              runIO $ hSetBuffering inP NoBuffering
              runIO $ hSetBuffering outP NoBuffering
              forM_ abstractCases (testAbstractSyn inP outP compilation)
              forM_ concreteCases (testConcreteSyn inP outP compilation))

     runIO (setCurrentDirectory curr)


<|start_filename|>backend/newlib/BaseTrans.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts, TypeOperators, MultiParamTypeClasses, ScopedTypeVariables, ViewPatterns #-}

module BaseTrans where

import           Control.Monad.Reader
import           Data.List (zip4, unzip4)
import qualified Language.Java.Syntax as J
import           Lens.Micro
import           Unbound.Generics.LocallyNameless

import           Inheritance
import           JavaLang
import           Panic
import qualified Src as S
import           StringPrefixes
import           Syntax
import           TransEnvironment

-- import Debug.Trace
-- import PrettyPrint

instance (:<) (Translate m) (Translate m) where
   up = id

type TransJavaExp = Either J.Name J.Literal

type TransType = ([J.BlockStmt], TransJavaExp, Expr)

data Translate m =
       T
         { translateM :: Expr -> m TransType
         , translateScopeM :: Bind Tele Expr -> Maybe TmName -> m ([J.BlockStmt], TransJavaExp, Bind Tele Expr)
         , translateIf :: m TransType -> m TransType -> m TransType -> m TransType
         , translateApply :: Expr -> Expr -> m TransType
         , translateScopeTy :: Tele -> TransType -> Maybe TmName -> m ([J.BlockStmt], TransJavaExp)
         , createWrap :: String -> Expr -> m J.CompilationUnit
         , transDefs :: Definition -> m [J.BlockStmt]
         }

createWrap' this str expr = do
  (bs, e, t) <- translateM this expr
  let returnStmt = [bStmt $ J.Return $ Just (unwrap e)]
  let returnType = applyRetType t
  let (javaCode, package) =
        case expr of
          (Module p _) ->
            -- FIXME: hack for main
            let mainStmt = extractStmt (last bs)
            in if null mainStmt
                 then (wrapperClass True str bs returnType mainModule, p)
                 else (wrapperClass True str (init bs) returnType (moduleMainBody mainStmt), p)
          _ -> (wrapperClass False str (bs ++ returnStmt) returnType mainBody, Nothing)
  return $ maybe
             (createCUB Nothing [javaCode])
             (\pname -> createCUB (Just (J.PackageDecl (name [pname]))) [javaCode])
             package

createCUB :: Maybe J.PackageDecl -> [J.TypeDecl] -> J.CompilationUnit
createCUB package compDef = cu
  where
    cu = J.CompilationUnit package [] compDef

applyRetType t =
  case t of
    JClass "java.lang.Integer" -> Just $ J.PrimType J.IntT
    JClass "java.lang.Boolean" -> Just $ J.PrimType J.BooleanT
    _                          -> Just objClassTy

trans :: (Fresh m, MonadReader Context m, selfType :< Translate m) => Base selfType (Translate m)
trans self =
  let this = up self
  in T
    { translateM  = translateM' this
    , translateIf = translateIf' this
    , translateScopeM = translateScopeM' this
    , translateScopeTy = translateScopeTy' this
    , translateApply = translateApply' this
    , createWrap = createWrap' this
    , transDefs = transDefs' this
    }


translateM' this e =
  case e of
    Var n -> do
      t <- lookupTy n
      return ([], var (show n), t)
    Lit lit ->
      case lit of
        (S.Int i)    -> return ([], Right $ J.Int i, JClass "java.lang.Integer")
        (S.UnitLit)  -> return ([], Right J.Null, Unit)
        (S.String s) -> return ([], Right $ J.String s, JClass "java.lang.String")
        (S.Bool b)   -> return ([], Right $ J.Boolean b, JClass "java.lang.Boolean")
        (S.Char c)   -> return ([], Right $ J.Char c, JClass "java.lang.Character")
    PrimOp op e1 e2 -> do
      (s1, j1, _) <- translateM this e1
      (s2, j2, _) <- translateM this e2
      let j1' = unwrap j1
      let j2' = unwrap j2
      let (je, t) =
            case op of
              (S.Arith realOp)   -> (J.BinOp j1' realOp j2', JClass "java.lang.Integer")
              (S.Compare realOp) -> (J.BinOp j1' realOp j2', JClass "java.lang.Boolean")
              (S.Logic realOp)   -> (J.BinOp j1' realOp j2', JClass "java.lang.Boolean")
      newName <- fresh (string2Name "prim" :: TmName)
      let assignExpr = localFinalVar (javaType t) (varDecl (show newName) je)
      return (s1 ++ s2 ++ [assignExpr], var (show newName), t)

    Lam bnd -> do
      (s, je, t) <- translateScopeM this bnd Nothing
      return (s, je, Pi t)

    App e1 e2 -> translateApply this e1 e2

    -- TODO: generalize?
    Mu bnd -> do
      ((x, Embed t), e) <- unbind bnd
      case e of
        Lam bnd -> do
          (s, je, _) <- extendCtx (mkTele [(x, t)]) (translateScopeM this bnd (Just x))
          return (s, je, t)

        _ -> panic "Expected a lambda abstraction after mu"

    Let bnd -> do
      ((x, Embed e), b) <- unbind bnd
      let x' = show x
      (s1, j1, t1) <- translateM this e
      -- FIXME: types do need to generate code
      if (aeq t1 estar)
        then translateM this (subst x e b)
        else do
          let jt1 = javaType t1
          let xDecl = localVar jt1 (varDecl x' $ unwrap j1)
          (s2, j2, t2) <- extendCtx (mkTele [(x, t1)]) (translateM this b)
          return (s1 ++ [xDecl] ++ s2, j2, t2)

    LetRec bnd -> do
      (unrec -> bnds', body) <- unbind bnd
      let bnds = unzip3 . map (\(n, Embed t, Embed def) -> (n, t, def)) $ bnds'
      let names = bnds ^. _1
      let types = bnds ^. _2
      let defs = bnds ^. _3
      let env = mkTele (zip names types)

      (bindStmts, bindExprs, bindTypes) <- unzip3 <$> mapM (\d -> extendCtx env (translateM this d)) defs
      (bodyStmts, bodyExpr, bodyType) <- extendCtx env (translateM this body)

      -- initialize declarations
      let bindJTypes = map javaType bindTypes
      let mDecls = map (\(n, btyp) -> memberDecl (fieldDecl btyp (varDeclNoInit (show n))))
                     (zip names bindJTypes)

      -- assign new created closures bindings to variables
      letClassName <- show <$> fresh (s2n letTransName)
      letVarName <- show <$> fresh (s2n "let")
      let assm = map (\(i, jz) -> bsAssign (name [show i]) jz) (names `zip` map unwrap bindExprs)
      let stasm = concatMap (\(a, b) -> a ++ [b]) (bindStmts `zip` assm)
      let letClass = localClass letClassName
                       (classBody (mDecls ++ [J.InitDecl False (J.Block stasm)]))

      -- after let class, some variable initialization
      let letVarInit = localVar (classTy letClassName)
                         (varDecl letVarName (instCreat (classTyp letClassName) []))
      let mVarsInit = map
                        (\(x, btyp) ->
                           (localVar btyp (varDecl x (fieldAccess (varExp letVarName) x))))
                        (zip (map show names) bindJTypes)


      return (letClass : letVarInit : mVarsInit ++ bodyStmts, bodyExpr, bodyType)


    If g e1 e2 -> translateIf this (translateM this g) (translateM this e1) (translateM this e2)

    F t e -> do
      (s, v, _) <- translateM this e
      return (s, v, t)

    U e -> do
      (s, v, t1) <- translateM this e
      let t2 = oneStep t1
      return (s, v, t2)

    Star -> do
      (js, v) <- createTypeHouse "star"
      return (js, v, Star)

    Pi _ -> do
      (js, v) <- createTypeHouse "pi"
      return (js, v, Star)

    JClass className -> do
      (stmts, jvar) <- createTypeHouse "jclass"
      return (stmts, jvar, Star)

    Unit -> do
      (stmts, jvar) <- createTypeHouse "unit"
      return (stmts, jvar, Star)

    Tuple tuple -> do
      case tuple of
        [t] -> do
          (s1, j1, t1) <- translateM this t
          return (s1, j1, Product [t1])
        _ -> do
          tuple' <- mapM (translateM this) tuple
          let (statements, exprs, types) = unzip3 tuple' & _1 %~ concat
          newVarName <- fresh (string2Name "tuple" :: TmName)
          let c = getTupleClassName tuple
          let rhs = instCreat (classTyp c) (map unwrap exprs)
          let assignExpr = localFinalVar (javaType $ JClass c) (varDecl (show newVarName) rhs)
          return (statements ++ [assignExpr], var (show newVarName), Product types)

    Proj index expr -> do
      ret@(statement, javaExpr, exprType) <- translateM this expr
      case exprType of
        Product [_] -> return ret
        Product types -> do
          newVarName <- fresh (string2Name "proj" :: TmName)
          let typ = types !! (index - 1)
          let aType = javaType typ
          let rhs = cast aType (fieldAccess (unwrap javaExpr) ("_" ++ show index))
          let assignExpr = localFinalVar (javaType typ) (varDecl (show newVarName) rhs)
          return (statement ++ [assignExpr], var $ show newVarName, typ)
        _ -> panic "BaseTransCFJava.trans: expected tuple type"

    JNew classname args -> do
      args' <- mapM (translateM this) args
      let (statements, exprs, types) = unzip3 args' & _1 %~ concat
      let rhs = J.InstanceCreation
                  (map
                     (\y -> case y of
                        JClass x -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident x, [])]
                        _        -> sorry "BaseTransCFJava.trans.JNew: no idea how to do")
                     types)
                  (J.ClassType [(J.Ident classname, [])])
                  (map unwrap exprs)
                  Nothing
      let typ = JClass classname
      newVarName <- fresh (string2Name "jnew" :: TmName)
      let assignExpr = localFinalVar (javaType typ) (varDecl (show newVarName) rhs)
      return (statements ++ [assignExpr], var (show newVarName), typ)

    JMethod receiver mname args retClassname -> do
      args' <- mapM (translateM this) args
      let (statements, exprs, types) = unzip3 args' & _1 %~ concat
      let exprs' = map unwrap exprs
      let refTypes =
            map
              (\y -> case y of
                 JClass x -> J.ClassRefType $ J.ClassType [(J.Ident x, [])]
                 _        -> sorry "BaseTransCFJava.trans.JMethod: no idea how to do")
              types
      (classStatement, rhs) <- case receiver of
                                 Right ce ->
                                   do
                                     (classS, classE, _) <- translateM this ce
                                     return
                                       (classS, J.MethodInv $ J.PrimaryMethodCall
                                                                (unwrap classE)
                                                                refTypes
                                                                (J.Ident mname)
                                                                exprs')
                                 Left cn ->
                                   return
                                     ([], J.MethodInv $ J.TypeMethodCall
                                                          (J.Name [J.Ident cn])
                                                          refTypes
                                                          (J.Ident mname)
                                                          exprs')
      if retClassname /= "java.lang.Void"
        then do
          let typ = JClass retClassname
          newVarName <- fresh (string2Name "jmcall" :: TmName)
          let assignExpr = localFinalVar (javaType typ) (varDecl (show newVarName) rhs)
          return (statements ++ classStatement ++ [assignExpr], var (show newVarName), typ)
        else return
               (statements ++ classStatement ++ [J.BlockStmt $ J.ExpStmt rhs], Right J.Null, Unit)

    JField receiver fname retClass -> do
      (classStatement, classExpr, _) <- case receiver of
                                          Right ce ->
                                            translateM this ce
                                          Left cn ->
                                            return ([], Left $ J.Name [J.Ident cn], undefined)
      newVarName <- fresh (string2Name "jfcall" :: TmName)
      let aType = javaType retClass
      let rhs = J.Cast aType $ J.FieldAccess $ J.PrimaryFieldAccess (unwrap classExpr)
                                                 (J.Ident fname)
          assignExpr = localFinalVar aType $ varDecl (show newVarName) rhs
      return (classStatement ++ [assignExpr], var (show newVarName), retClass)

    Seq es -> do
      es' <- mapM (translateM this) es
      let (_, lastExp, lastType) = last es'
      let statements = concatMap (\(x, _, _) -> x) es'
      return (statements, lastExp, lastType)

    Module _ defs -> do
      defStmts <- transDefs this defs
      return (defStmts, var tempvarstr, Unit)

translateIf' this m1 m2 m3 = do
  (s1, j1, _) <- m1
  (s2, j2, t2) <- m2
  (s3, j3, t3) <- m3
  ifname <- fresh (string2Name ifresultstr :: TmName)
  let ifvarname = show ifname
  let jtype = javaType t2

  let ifresdecl = localVar jtype (varDeclNoInit ifvarname)
  let thenPart  = J.StmtBlock $ block (s2 ++ [bsAssign (name [ifvarname]) (unwrap j2)])
  let elsePart  = J.StmtBlock $ block (s3 ++ [bsAssign (name [ifvarname]) (unwrap j3)])
  let ifstmt    = bStmt $ J.IfThenElse (unwrap j1) thenPart elsePart

  return (s1 ++ [ifresdecl,ifstmt],var ifvarname ,t2)


translateScopeM' this bnd n = do
  (delta, m) <- unbind bnd
  (bodyBS, bodyV, bodyT) <- extendCtx delta (translateM this m)

  (closureBS, cx1) <- translateScopeTy this delta (bodyBS, bodyV, bodyT) n

  return (closureBS, cx1, bind delta bodyT)

{-

\(x1 : t1)(..) . e

==>

class Fcx1 extends Closure {

  Closure cx1 = this;

  public void apply() {
    final |t1| x1 = cx1.arg;
    <...>
  }
}
Closure cx1 = new Fcx1();

-}
translateScopeTy' this b (ostmts, oexpr, t1) n = transScopeTy' b
  where
    transScopeTy' (Cons bnd) = do
      let ((x1, Embed t1), b) = unrebind bnd

      let cx1 = maybe ("c" ++ show x1) (show . id) n -- FIXME: use prefix

      let accessField = fieldAccess (left $ var cx1) closureInput
      let xf = initClass (javaType t1) (show x1) accessField

      (body', xe) <- case b of
                       Empty   -> return (ostmts, oexpr)
                       Cons b' -> transScopeTy' b

      let fstmt = localVar closureType (varDecl cx1 (funInstCreate cx1))

      return
        ([ localClassDecl (closureTransName ++ cx1) closureClass
             (closureBodyGen [memberDecl $ fieldDecl (classTy closureClass) (varDecl cx1 J.This)]
                ([xf] ++ body' ++ [bsAssign (name [closureOutput]) (unwrap xe)]))
         , fstmt
         ], var cx1)



{-

(\(x1:t1)..) e

==>

class Fx1 extends Closure {
<..>
}
Closure cx1 = new Fx1();

cx1.arg = j2;
cx1.apply();
|retTy| rx1 = |retTy| cx1.res;


-}
translateApply' this e1 e2 = do
  (s1, j1, Pi bnd) <- translateM this e1
  (d@(Cons de), b) <- unbind bnd
  let ((x1, _), de') = unrebind de
  (s2, j2, _) <- translateM this e2
  let (d', b') = multiSubst d e2 b
  let retTy =
        case d' of
          Empty -> b'
          _     -> Pi (bind d' b')

  let fexp = unwrap j1
  let fs = assignField (fieldAccExp fexp closureInput) (unwrap j2)
  let fapply = bStmt . applyMethodCall $ fexp
  let fout = fieldAccess fexp closureOutput
  let fret = "r" ++ show x1
  let fres = [initClass (javaType retTy) fret fout]

  return (s1 ++ s2 ++ (fs : fapply : fres), var fret, retTy)

createTypeHouse :: (Fresh m) => String -> m ([J.BlockStmt], TransJavaExp)
createTypeHouse str = do
  typeVar <- show <$> fresh (s2n str)
  let fstmt = [ localVar typeOfType (varDecl typeVar typeHouseCreate)
              -- , assignField (fieldAccExp (left . var $ typeVar) typeField) (J.Lit (J.String str))
              ]
  return (fstmt, var typeVar)


initClass :: J.Type -> String -> J.Exp -> J.BlockStmt
initClass ty tempName expr =
  localFinalVar ty
    (varDecl tempName
       (if ty == objClassTy
          then expr
          else cast ty expr))

getTupleClassName :: [a] -> String
getTupleClassName tuple =
  if lengthOfTuple > 50
    then panic "The length of tuple is too long (>50)!"
    else namespace ++ "tuples.Tuple" ++ show lengthOfTuple
  where
    lengthOfTuple = length tuple

javaType ty =
  case ty of
    Pi _ -> classTy closureClass
    (JClass c) -> classTy c
    (Product tuple) ->
      case tuple of
        [t] -> javaType t
        _   -> classTy $ getTupleClassName tuple
    _ -> objClassTy


transDefs' this defs =
  case defs of
    Def bnd -> do
      ((fname, Embed srcTyp, Embed expr), otherDef) <- unbind bnd
      (bs, e, t) <- translateM this expr
      otherDefStmts <- (extendCtx (mkTele [(fname, t)])) $ transDefs this otherDef
      let typ = javaType t
      -- Note: `name2string` return original name
      let originalName = name2String fname
      let anno = normalAnno originalName (show fname) (show srcTyp)
      let xDecl = localVarWithAnno anno typ (varDecl (show fname) $ unwrap e)

      case otherDef of
        -- FIXME: hack to group translations of main method
        DefNull
          | originalName == "main" -> return ([groupStmt (bs ++ (mainPrint (unwrap e)))])
        _ -> return (bs ++ [xDecl] ++ otherDefStmts)
    DefRec bnd ->
      do
        (defList, body) <- unbind bnd
        let (names, stypes', types', exprs') = unzip4 $ unrec defList
        let stypes = map unembed stypes'
        let types = map unembed types'
        let exprs = map unembed exprs'
        let newBindings = (mkTele $ zip names types)
        (bindStmts, bindExprs, tBinds) <- unzip3 <$> (mapM (extendCtx newBindings . translateM this)
                                                        exprs)
        bodyStmts <- (extendCtx newBindings) $ transDefs this body
        let bindtyps = map javaType tBinds
        let annos = map (\(fname, srcTyp) -> normalAnno (name2String fname) (show fname) srcTyp)
                      (zip names (map show stypes))
        let assm = map (\(anno, fname, typ, e) -> localVarWithAnno anno typ (varDecl (show fname) $ unwrap e))
                     (zip4 annos names bindtyps bindExprs)
        return (concatMap (\(a, b) -> a ++ [b]) (bindStmts `zip` assm) ++ bodyStmts)
    DefNull -> return []


<|start_filename|>examples/sierpinsky/lib/DrawFrame.java<|end_filename|>
package lib;

import java.awt.*;
import javax.swing.*;
import java.awt.image.BufferedImage;


public class DrawFrame extends JFrame {

    private static int level;
    private static int x = 0, y = 0, SIZE = 4 * 128, dist;
    private static BufferedImage bufferedImage = new BufferedImage(SIZE, SIZE, BufferedImage.TYPE_INT_RGB);
    private static DrawFrame s = null;

    public static void create(int level, int dist) {
        DrawFrame.level = level;
        DrawFrame.dist = dist;
        x = 2 * dist;
        y = dist;
        s = new DrawFrame();
    }

    public static void refresh() {
        s.repaint();
    }

    private DrawFrame() {
        setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE);
        setSize(SIZE, SIZE);
        setVisible(true);
    }

    public void paint(Graphics g)
    {
        super.paint(g);
        g.drawImage(bufferedImage, 0, 0, null);
    }

    public static void lineTo(int deltaX, int deltaY) {
        bufferedImage.getGraphics().drawLine(x, y, x + deltaX, y + deltaY);
        x += deltaX;
        y += deltaY;
    }
}



<|start_filename|>frontend/typecheck/Checker.hs<|end_filename|>
{-
Infrastructure for typechecking.
-}
{-# LANGUAGE RecordWildCards #-}
module Checker where

import           IOEnv
import           JavaUtils
import qualified JvmTypeQuery
import           Src
import           SrcLoc
import           TypeErrors

import           Control.Monad.Except
import qualified Data.Map as Map
import qualified Data.Set as Set

type Checker a = ExceptT (Located TypeError) (IOEnv CheckerState) a

getCheckerState :: Checker CheckerState
getCheckerState = lift getEnv

setCheckerState :: CheckerState -> Checker ()
setCheckerState tc_env = lift $ setEnv tc_env

getTypeContext :: Checker TypeContext
getTypeContext = liftM checkerTypeContext getCheckerState

getValueContext :: Checker ValueContext
getValueContext = liftM checkerValueContext getCheckerState

getTypeServer :: Checker JvmTypeQuery.Connection
getTypeServer = liftM checkerTypeServer getCheckerState

getMemoizedJavaClasses :: Checker (Set.Set ClassName)
getMemoizedJavaClasses = liftM checkerMemoizedJavaClasses getCheckerState

memoizeJavaClass :: ClassName -> Checker ()
memoizeJavaClass c
  = do CheckerState{..} <- getCheckerState
       memoized_java_classes <- getMemoizedJavaClasses
       setCheckerState CheckerState{ checkerMemoizedJavaClasses = c `Set.insert` memoized_java_classes, ..}

withLocalTVars :: [(Name, Kind)] -> Checker a -> Checker a
withLocalTVars tvars do_this
  = do delta <- getTypeContext
       let delta' = addTVarToContext tvars delta
       CheckerState {..} <- getCheckerState
       setCheckerState CheckerState { checkerTypeContext = delta', ..}
       r <- do_this
       CheckerState {..} <- getCheckerState
       setCheckerState CheckerState { checkerTypeContext = delta, ..}
       return r

withLocalConstrainedTVars :: [(Name, Maybe Type)] -> Checker a -> Checker a
withLocalConstrainedTVars tvars do_this
 = do delta <- getTypeContext
      let delta' = addConstrainedTVarToContext tvars delta
      CheckerState {..} <- getCheckerState
      setCheckerState CheckerState { checkerTypeContext = delta', ..}
      r <- do_this
      CheckerState {..} <- getCheckerState
      setCheckerState CheckerState { checkerTypeContext = delta, ..}
      return r

withTypeSynonym :: [(Name, Type, Kind)] -> Checker a -> Checker a
withTypeSynonym tvars do_this
  = do delta <- getTypeContext
       let delta' = addTypeSynonym tvars delta
       CheckerState {..} <- getCheckerState
       setCheckerState CheckerState { checkerTypeContext = delta', ..}
       r <- do_this
       CheckerState {..} <- getCheckerState
       setCheckerState CheckerState { checkerTypeContext = delta, ..}
       return r

withLocalVars :: [(Name, Type)]-> Checker a -> Checker a
withLocalVars vars do_this
  = do gamma <- getValueContext
       let gamma' = addVarToContext vars gamma
       CheckerState {..} <- getCheckerState
       setCheckerState CheckerState { checkerValueContext = gamma', ..}
       r <- do_this
       CheckerState {..} <- getCheckerState
       setCheckerState CheckerState { checkerValueContext = gamma, ..}
       return r

data CheckerState
  = CheckerState
  { checkerTypeContext  :: TypeContext
  , checkerValueContext :: ValueContext
  , checkerTypeServer   :: JvmTypeQuery.Connection
  , checkerMemoizedJavaClasses :: Set.Set ClassName -- Memoized Java class names
  }

mkInitCheckerState :: JvmTypeQuery.Connection -> CheckerState
mkInitCheckerState type_server
  = CheckerState
  { checkerTypeContext     = Map.empty
  , checkerValueContext    = Map.empty
  , checkerTypeServer   = type_server
  , checkerMemoizedJavaClasses = Set.empty
  }

-- Temporary hack for REPL
mkInitCheckerStateWithEnv :: ValueContext -> JvmTypeQuery.Connection -> CheckerState
mkInitCheckerStateWithEnv value_ctxt type_server
  = CheckerState
  { checkerTypeContext     = Map.empty
  , checkerValueContext    = value_ctxt
  , checkerTypeServer   = type_server
  , checkerMemoizedJavaClasses = Set.empty
  }

lookupVar :: Name -> Checker (Maybe Type)
lookupVar x
  = do valueCtxt <- getValueContext
       return (Map.lookup x valueCtxt)

lookupTVarKind :: Name -> Checker (Maybe Kind)
lookupTVarKind a
 = do typeCtxt <- getTypeContext
      return (fmap (\(kind,_,_) -> kind) (Map.lookup a typeCtxt))

subtype :: Type -> Type -> Checker Bool
subtype t1 t2
  = do typeCtxt <- getTypeContext
       return (Src.subtype typeCtxt t1 t2)


<|start_filename|>backend/archive/ClosureFNew.hs<|end_filename|>
{-# Language RankNTypes, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall #-}
{- |
Module      :  ClosureFNew
Description :   Abstract syntax and pretty printer for ClosureFNew.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Tomas <<EMAIL>>
Stability   :  stable
Portability :  non-portable (MPTC)

-}
module ClosureFNew where

import qualified CoreNew as C
import           JavaUtils
import           Panic
import           PrettyUtils
import qualified Src as S
import qualified Language.Java.Pretty (prettyPrint)
import           Prelude hiding ((<$>))
import           Text.PrettyPrint.ANSI.Leijen

-- Closure F syntax

-- FIXME: This is probably wrong, because it would group pi and lambda
-- together
data Scope e =
      Body (Expr e)
    | Type (Type e) (e -> Scope e)

type Type t = Expr t

data Expr e =
     Var S.Name e
   | Lit S.Lit

   | Lam S.Name (Scope e)
   | Pi S.Name (Scope e)
   | Mu S.Name (Scope e)
   | Let S.Name (Expr e) (e -> Expr e)
   | App (Expr e) (Expr e)

   | If (Expr e) (Expr e) (Expr e)
   | PrimOp (Expr e) S.Operator (Expr e)

   | CastUp (Expr e) (Expr e)
   | CastDown (Expr e) (Expr e)

   | Tuple [Expr e]
   | Proj Int (Expr e)
   | TupleType [Type e]
   | Unit
   | Star

   | JNew ClassName [Expr e]
   | JMethod (Either ClassName (Expr e)) MethodName [Expr e] ClassName
   | JField  (Either ClassName (Expr e)) FieldName (Type e)
   | JClass ClassName

   | SeqExprs [Expr e]
   | Error (Type e) (Expr e)

-- System F to Closure F

fexp2scope :: C.Expr e -> Scope e
fexp2scope (C.Pi _ t f)  = Type (fexp2cexp t) (fexp2scope . f)
fexp2scope (C.Lam _ t f) = Type (fexp2cexp t) (fexp2scope . f)
fexp2scope (C.Mu _ t f)  = Type (fexp2cexp t) (fexp2scope . f)
fexp2scope e             = Body (fexp2cexp e)

fexp2cexp :: C.Expr e -> Expr e -- TODO: Datatypes missing
fexp2cexp (C.JClass c)               = JClass c
fexp2cexp (C.Product ts)             = TupleType (map fexp2cexp ts)
fexp2cexp (C.Unit)                   = Unit
fexp2cexp (C.Star)                   = Star
fexp2cexp t@(C.Pi n _ _)             = Pi n (fexp2scope t)
fexp2cexp e@(C.Lam n _ _)            = Lam n (fexp2scope e)
fexp2cexp e@(C.Mu n _ _)             = Mu n (fexp2scope e)
fexp2cexp (C.Var rid x)              = Var rid x
fexp2cexp (C.App e1 e2)              = App (fexp2cexp e1) (fexp2cexp e2)
fexp2cexp (C.CastUp e1 e2)           = CastUp (fexp2cexp e1) (fexp2cexp e2)
fexp2cexp (C.CastDown e1 e2)         = CastDown (fexp2cexp e1) (fexp2cexp e2)
fexp2cexp (C.PrimOp e1 op e2)        = PrimOp (fexp2cexp e1) op (fexp2cexp e2)
fexp2cexp (C.Lit S.UnitLit)          = Lit S.UnitLit
fexp2cexp (C.Lit e)                  = Lit e
fexp2cexp (C.If e1 e2 e3)            = If (fexp2cexp e1) (fexp2cexp e2) (fexp2cexp e3)
fexp2cexp (C.Tuple tuple)            = Tuple (map fexp2cexp tuple)
fexp2cexp (C.Proj i e)               = Proj i (fexp2cexp e)
fexp2cexp (C.Let n bind body)        = Let n (fexp2cexp bind) (fexp2cexp . body)
fexp2cexp (C.JNew cName args)        = JNew cName (map fexp2cexp args)
fexp2cexp (C.JMethod c mName args r) =
  case c of (S.NonStatic ce) -> JMethod (Right $ fexp2cexp ce) mName (map fexp2cexp args) r
            (S.Static cn)    -> JMethod (Left cn) mName (map fexp2cexp args) r
fexp2cexp (C.JField c fName r)       =
  case c of (S.NonStatic ce) -> JField (Right $ fexp2cexp ce) fName (fexp2cexp r)
            (S.Static cn)    -> JField (Left cn) fName (fexp2cexp r)
fexp2cexp (C.Error ty str)           = Error (fexp2cexp ty) (fexp2cexp str)
fexp2cexp (C.Seq es)                 = SeqExprs (map fexp2cexp es)

adjust :: C.Type t -> Scope t -> Scope t
adjust (C.Pi _ _ f) (Type t' g) = Type t' (\t -> adjust (f t) (g t))
adjust t (Body _)               = Body (fexp2cexp t)
adjust _ _ = sorry "ClosureFNew.adjust: no idea how to do"

-- join

scope2ctyp :: Scope t -> Type t
scope2ctyp (Body t)  = t
scope2ctyp s         = Pi "_" s

getArity :: Scope t -> Int
getArity (Type _ g) = 1 + getArity (g undefined) -- TODO: better choice
getArity _ = 0

joinType :: Type (Type t) -> Type t
joinType (Var _ t)   = t
joinType Unit = Unit
joinType Star = Star
joinType (Pi n s) = Pi n (joinTScope s)
joinType (JClass c) = JClass c
joinType (TupleType ts) = TupleType (map joinType ts)
joinType _ = error "ClosureFNew.joinType: not defined"

joinTScope :: Scope (Type t) -> Scope t
joinTScope (Body b)   = Body (joinType b)
joinTScope (Type t f) = Type (joinType t) (joinTScope . f . Var "")

-- Free variable substitution

substScope :: Subst t => Int -> Type Int -> Scope t  -> Scope t
substScope n t (Body t1) = Body (substType n t t1)
substScope n t (Type t1 f) = Type (substType n t t1) (substScope n t . f)

substType :: Subst t => Int -> Type Int -> Type t -> Type t
substType n t (Var _ x) = subst n t x
substType n t (Pi n' s) = Pi n' (substScope n t s)
substType _ _ x = x

class Subst t where
   subst :: Int -> Type Int -> t -> Type t

instance Subst Int where
   subst n t x
      | n == x = t
      | otherwise = Var "" x

instance Subst t => Subst (Type t) where
   subst n t x = Var "" (substType n t x)

-- Pretty Printing
-- TODO: fix pretty printing with the propagated names
type Index = Int

pretty :: Expr Index -> Doc
pretty = prettyExpr basePrec 0

isSimpleExpr :: Expr Index -> Bool
isSimpleExpr (Var _ _)         = True
isSimpleExpr (PrimOp{})  = True
isSimpleExpr (App (Var _ _) _) = True
isSimpleExpr (Lit _)         = True
isSimpleExpr _               = False

prettyScope :: Prec -> Index -> Scope Index -> Doc
prettyScope p i (Body t) = prettyExpr p i t
prettyScope p i (Type t f) = backslash <+> parens (prettyVar i <+> colon <+> prettyExpr p (i + 1) t) <> dot <$> prettyScope p (i + 1) (f i)

prettyExpr :: Prec -> Index -> Expr Index -> Doc
prettyExpr _ _ Unit = text "Unit"
prettyExpr _ _ Star = text "Star"

prettyExpr _ _ (JClass "java.lang.Integer") = text "Int"
prettyExpr _ _ (JClass "java.lang.String") = text "String"
prettyExpr _ _ (JClass "java.lang.Boolean") = text "Bool"
prettyExpr _ _ (JClass "java.lang.Character") = text "Char"
prettyExpr _ _ (JClass c) = text c

prettyExpr p i (TupleType l) = tupled (map (prettyExpr p i) l)

prettyExpr _ _ (Var _ x) = prettyVar x

prettyExpr p i (Lam _ e) = nest 2 (text "Lam(" <$> prettyScope p i e) <$> text ")"
prettyExpr p i (Mu _ e) = nest 2 (text "Mu(" <$> prettyScope p i e) <$> text ")"
prettyExpr p i (Pi _ e) = nest 2 (text "Pi(" <$> prettyScope p i e) <$> text ")"

prettyExpr p i (App (Lam _ e1) e2) =
  nest 2 (text "App(" <$>
  prettyExpr p i (Lam "" e1) <> comma <$>
  prettyExpr p i e2) <$>
  text ")"

-- To be modified. Remove useless parens.
prettyExpr p i (App e1 e2) = parensIf p 4 (prettyExpr (4, PrecMinus) i e1 <+> prettyExpr (4, PrecPlus) i e2)

prettyExpr p i (CastUp t e)
  = parensIf p 2 $ castup <> (brackets (prettyExpr (2, PrecMinus) i t)) <+> prettyExpr (2, PrecMinus) i e

prettyExpr p i (CastDown t e)
  = parensIf p 2 $ castdown <> (brackets (prettyExpr (2, PrecMinus) i t)) <+> prettyExpr (2, PrecMinus) i e


prettyExpr p i (PrimOp e1 op e2)
  = parens (prettyExpr p i e1 <+> pretty_op <+> prettyExpr p i e2)
  where
    pretty_op = text (Language.Java.Pretty.prettyPrint java_op)
    java_op   = case op of
                  S.Arith   op' -> op'
                  S.Compare op' -> op'
                  S.Logic   op' -> op'


prettyExpr _ _ (Lit (S.Int n))    = integer n
prettyExpr _ _ (Lit (S.String s)) = dquotes (string s)
prettyExpr _ _ (Lit (S.Bool b))   = bool b
prettyExpr _ _ (Lit (S.Char c))   = char c
prettyExpr _ _ (Lit  S.UnitLit)   = unit

prettyExpr _ i (If e1 e2 e3)
  = ifPart <$> thenPart <$> elsePart
  where
    ifPart   = text "if" <+> prettyExpr (3, PrecMinus) i e1
    thenPart = if   isSimpleExpr e2
               then text "then" <+> prettyExpr (3, PrecMinus) i e2
               else nest 2 (text "then" <$> prettyExpr (3, PrecMinus) i e2)
    elsePart = if   isSimpleExpr e3
               then text "else" <+> prettyExpr (3, PrecMinus) i e3
               else nest 2 (text "else" <$> prettyExpr (3, PrecMinus) i e3)

prettyExpr p i (Tuple l) = tupled (map (prettyExpr p i) l)

--To be modified. Remove useless parens.
prettyExpr p i (Proj n e) = parensIf p 5 (prettyExpr (5, PrecMinus) i e <> text "._" <> int n)

prettyExpr _ i (Let _ x f) =
  text "let" <$$>
  indent 2 (prettyVar i <+> text "=" <+> prettyExpr basePrec (succ i) x) <$$>
  text "in" <$$>
  indent 2 (prettyExpr basePrec (succ i) (f i))

prettyExpr p i (JNew name l) = parens (text "new" <+> text name <> tupled (map (prettyExpr p i) l))

prettyExpr _ i (JMethod name m args _) = methodStr name <> dot <> text m <> tupled (map (prettyExpr basePrec i) args)
  where
    methodStr (Left x)  = text x
    methodStr (Right x) = prettyExpr (6,PrecMinus) i x

prettyExpr _ i (JField name f _) = fieldStr name <> dot <> text f
  where
    fieldStr (Left x)  = text x
    fieldStr (Right x) = prettyExpr (6,PrecMinus) i x

prettyExpr p i (Error _ str) = text "error:" <+> prettyExpr p i str

prettyExpr p i (SeqExprs l) = semiBraces (map (prettyExpr p i) l)


<|start_filename|>backend/newlib/Syntax.hs<|end_filename|>
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-}

module Syntax where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Trans.Maybe
import           Data.List (zip4)
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           Unbound.Generics.LocallyNameless

import qualified Core as C
import           JavaUtils
import qualified Language.Java.Syntax as J
import           Panic
import qualified Src as S


type TmName = Name Expr

data Tele = Empty
          | Cons (Rebind (TmName, Embed Type) Tele)
  deriving (Show, Generic, Typeable)

type Scope = Bind Tele Expr

type JReceiver = Either ClassName Expr

type Type = Expr

-- | Syntax of the core
data Expr = Var TmName
          | App Expr Expr
          | Lam Scope
          | Pi Scope
          | Mu (Bind (TmName, Embed Type) Expr)
          | F Expr Expr
          | U Expr
          | Star

          | Let (Bind (TmName, Embed Type) Expr)
          | LetRec (Bind (Rec [(TmName, Embed Type, Embed Expr)]) Expr)

          | If Expr Expr Expr

          | Lit S.Lit
          | PrimOp S.Operator Expr Expr

          | Unit

          | JClass ClassName
          | JNew ClassName [Expr]
          | JMethod JReceiver MethodName [Expr] ClassName
          | JField JReceiver FieldName Expr

          -- TODO: generalize to dependent pair
          | Product [Expr]
          | Tuple [Expr]
          | Proj Int Expr

          | Sum (Bind (TmName, Embed Type) Expr)
          | Pack (Expr, Expr) Type
          | UnPack (Expr, Expr) Expr Expr

          | Seq [Expr]
          -- Module
          | Module (Maybe S.PackageName) Definition

  deriving (Show, Generic, Typeable)


data Definition = Def (Bind (TmName, Embed S.Type, Embed Expr) Definition)
                | DefRec (Bind (Rec [(TmName, Embed S.Type, Embed Type, Embed Expr)]) Definition)
                | DefNull
                deriving (Show, Generic, Typeable)

instance Alpha Expr
instance Alpha S.Lit
instance Alpha S.Operator
instance Alpha J.Op
instance Alpha S.Type
instance Alpha Tele
instance Alpha Definition

instance Subst Expr S.Operator
instance Subst Expr S.Lit
instance Subst Expr J.Op
instance Subst Expr Tele
instance Subst Expr Definition
instance Subst Expr S.Type

instance Subst Expr Expr where
  isvar (Var v) = Just (SubstName v)
  isvar _ = Nothing


-- smart constructors

evar :: String -> Expr
evar = Var . string2Name

elam :: [(TmName, Expr)] -> Expr -> Expr
elam t b = Lam (bind (mkTele t) b)

emu :: (String, Expr) -> Expr -> Expr
emu (n, t) b = Mu (bind (string2Name n, embed t) b)

edef :: (TmName, S.Type) -> Expr -> Definition -> Definition
edef (n, t) e b = Def (bind (n, embed t, embed e) b)

edefrec :: [(TmName, S.Type, Type, Expr)] -> Definition -> Definition
edefrec xs e = DefRec (bind binds e)
  where
    binds = rec (map (\(n, t1, t2, b) -> (n, embed t1, embed t2, embed b)) xs)

epi :: [(TmName, Expr)] -> Expr -> Expr
epi t b = Pi (bind (mkTele t) b)

earr :: Expr -> Expr -> Expr
earr t1 = epi [(string2Name "_", t1)]

esum :: Expr -> Expr -> Expr
esum e1 e2 = Sum (bind (s2n "_", embed e1) e2)

estar :: Expr
estar = Star

eapp :: Expr -> Expr -> Expr
eapp = App

elet :: String -> Expr -> Expr -> Expr
elet n e1 e2 = Let (bind (s2n n, embed e1) e2)

eletrec :: [(TmName, Type, Expr)] -> Expr -> Expr
eletrec xs e = LetRec (bind binds e)
  where binds = rec (map (\(n, t, b) -> (n, embed t, embed b)) xs)

mkTele :: [(TmName, Expr)] -> Tele
mkTele []          = Empty
mkTele ((x,e) : t) = Cons (rebind (x, Embed e) (mkTele t))


-- Old Core to New Core Translation

core2New :: Fresh m => C.Expr TmName TmName -> m Expr
core2New = transExpr
  where
    -- TODO: missing datatype, letrec
    transExpr :: Fresh m => C.Expr TmName TmName -> m Expr
    transExpr (C.Var _ e) = return $ Var e
    transExpr (C.Lit l) = return $ Lit l

    transExpr e@(C.Lam n t f) = do
      (tele, body) <- getLambda e
      return $ elam tele body

    transExpr (C.Fix n1 n2 f t1 t) = do
      fun <- transType (C.Fun t1 t)
      t1' <- transType t1
      n1' <- fresh (string2Name n1)
      n2' <- fresh (string2Name n2)
      f' <- transExpr (f n1' n2')
      return $ Mu (bind (n1', Embed fun) (elam [(n2', t1')] f'))

    transExpr (C.Let n b e) = do
      letName <- fresh (string2Name n)
      b' <- transExpr b
      e' <- transExpr (e letName)
      return (Let (bind (letName, Embed b') e'))

    transExpr (C.LetRec ns ts bs body) = do
      ns' <- mapM (fresh . s2n) ns
      ts' <- mapM transType ts
      bs' <- mapM transExpr (bs ns')
      body' <- transExpr (body ns')
      return $ eletrec (zip3 ns' ts' bs') body'

    transExpr e@(C.BLam n f) = do
      (tele, body) <- getLambda e
      return $ elam tele body
    transExpr (C.App f e) = eapp <$> (transExpr f) <*> (transExpr e)
    transExpr (C.TApp f e) = eapp <$> (transExpr f) <*> (transType e)
    transExpr (C.If e1 e2 e3) = If <$> (transExpr e1) <*> (transExpr e2) <*> (transExpr e3)
    transExpr (C.PrimOp e1 op e2) = PrimOp op <$> (transExpr e1) <*> (transExpr e2)
    transExpr (C.JNew name args) = JNew name <$> (mapM transExpr args)
    transExpr (C.JMethod rcv mname args cname) = do
      args' <- mapM transExpr args
      rcv' <- transRecv rcv
      return (JMethod rcv' mname args' cname)
    transExpr (C.JField rcv fname t) =
      do
        rcv' <- transRecv rcv
        t' <- transType t
        return (JField rcv' fname t')
    transExpr (C.Tuple es) = do
      es' <- mapM transExpr es
      return $ Tuple es'
    transExpr (C.Proj i e) = do
      e' <- transExpr e
      return $ Proj i e'
    transExpr (C.Seq es) = do
      es' <- mapM transExpr es
      return $ Seq es'

    transExpr (C.Module n defs) = Module n <$> (trans defs)
      where
        trans C.Null = return DefNull
        trans (C.Def fname ty e def) = do
          e' <- transExpr e
          let fname' = string2Name fname -- Note: don't generate fresh name here
          def' <- trans (def fname')
          return $ edef (fname', ty) e' def'
        trans (C.DefRec names tys es defs) = do
          let names' = map s2n names
          let t1' = map fst tys
          t2' <- mapM (transType . snd) tys
          es' <- mapM transExpr (es names')
          defs' <- trans (defs names')
          return $ edefrec (zip4 names' t1' t2' es') defs'

    transExpr _ = sorry "Syntax.transExpr: not defined"

    transRecv :: Fresh m => S.JReceiver (C.Expr TmName TmName) -> m JReceiver
    transRecv (S.Static c) = return (Left c)
    transRecv (S.NonStatic e) = do
      e' <- (transExpr e)
      return (Right e')

    transType :: Fresh m => C.Type TmName -> m Type
    transType (C.TVar _ x) = return $ Var x
    transType (C.JClass c) = return $ JClass c
    transType (C.Fun t1 t2) = do
      t1' <- transType t1
      t2' <- transType t2
      return $ earr t1' t2'
    transType (C.Forall n f) = do
      forName <- fresh (string2Name n)
      f' <- transType (f forName)
      return $ epi [(forName, Star)] f'
    transType C.Unit = return Unit
    transType (C.Product ts) = do
      ts' <- mapM transType ts
      return $ Product ts'
    transType _ = sorry "Syntax.transType: not defined"

    getLambda :: Fresh m => C.Expr TmName TmName -> m ([(TmName, Expr)], Expr)
    getLambda = collect []
      where
        collect bag (C.Lam n t f) = do
          n' <- fresh (string2Name n)
          t' <- transType t
          collect ((n', t') : bag) (f n')
        collect bag (C.BLam n f) = do
          n' <- fresh (string2Name n)
          collect ((n', Star) : bag) (f n')
        collect bag e = do
          e' <- transExpr e
          return (reverse bag, e')


{-
-- even and odd
evenOdd :: Expr
evenOdd =
  let even = s2n "even"
      odd = s2n "odd"
  in eletrec
       [ (even, (earr javaInt javaInt), elam [(x, javaInt)]
                                          (If
                                             (PrimOp (S.Compare J.Equal) (Var x) (Lit (S.Int 0)))
                                             (Lit (S.Int 0))
                                             (App (Var odd)
                                                (PrimOp (S.Arith J.Sub) (Var x) (Lit (S.Int 1))))))
       , (odd, (earr javaInt javaInt), elam [(x, javaInt)]
                                         (If
                                            (PrimOp (S.Compare J.Equal) (Var x) (Lit (S.Int 0)))
                                            (Lit (S.Int 1))
                                            (App (Var even)
                                               (PrimOp (S.Arith J.Sub) (Var x) (Lit (S.Int 1))))))
       ]
       (App (Var odd) (Lit (S.Int 3)))

x :: TmName
y :: TmName
z :: TmName
(x,y,z) = (string2Name "x", string2Name "y", string2Name "z")

javaInt :: Expr
javaInt = JClass "Integer"

javaBool :: Expr
javaBool = JClass "Bool"

-}


<|start_filename|>frontend/Panic.hs<|end_filename|>
{-# LANGUAGE DeriveDataTypeable #-}
{- |
Module      :  Panic
Description :  Utilities for throwing exceptions in the compiler.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module Panic
  ( F2jException(..)
  , showF2jException
  , throwF2jException, throwF2jExceptionIO

  , panic, sorry
  , prettyPanic, prettySorry
  , panicOnSameDataCons
  ) where

import Text.PrettyPrint.ANSI.Leijen
import Control.Exception
import Data.Data

data F2jException
  -- | The 'impossible' happened.
  = Panic String (Maybe Doc)

  -- | The user tickled something that's known not to work yet,
  --   but we're not counting it as a bug.
  | Sorry String (Maybe Doc)
  deriving (Typeable)

instance Exception F2jException

instance Show F2jException where
  showsPrec _ = showF2jException

showF2jException :: F2jException -> String -> String
showF2jException exception
  = case exception of
      Panic s maybe_doc ->
        showString $
          "panic! (the 'impossible' happened)\n" ++
          s ++ showMaybeDoc maybe_doc ++ "\n\n" ++
          "Please report this as a bug:  " ++
          "https://github.com/hkuplg/fcore/issues/new"

      Sorry s maybe_doc ->
        showString $
          "sorry! (unimplemented feature or known bug)\n\t" ++
          s ++ showMaybeDoc maybe_doc
  where
    showMaybeDoc Nothing    = ""
    showMaybeDoc (Just doc) = ": " ++ show doc

throwF2jException :: F2jException -> a
throwF2jException = Control.Exception.throw

throwF2jExceptionIO :: F2jException -> IO a
throwF2jExceptionIO = Control.Exception.throwIO

-- | Panic and asserts.
panic, sorry :: String -> a
panic s = throwF2jException (Panic s Nothing)
sorry s = throwF2jException (Sorry s Nothing)

prettyPanic, prettySorry :: String -> Doc -> a
prettyPanic s doc = throwF2jException (Panic s (Just doc))
prettySorry s doc = throwF2jException (Sorry s (Just doc))

panicOnSameDataCons :: (Data a, Data b) => result -> (String, a, b) -> result
result `panicOnSameDataCons` (panic_msg, t1, t2)
  | toConstr t1 == toConstr t2 = panic panic_msg
  | otherwise                  = result


<|start_filename|>frontend/IOEnv.hs<|end_filename|>
{- |
Module      :  IOEnv
Description :  The main monad used in the type checker.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module IOEnv
  ( IOEnv(..)
  , runIOEnv, evalIOEnv, execIOEnv
  , getEnv, setEnv, localEnv
  ) where

import Control.Monad.State

newtype IOEnv env a = IOEnv { unIOEnv :: StateT env IO a }
  -- Recall:
  -- newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }


instance Monad (IOEnv m) where
  return = returnM
  (>>=)  = thenM

instance Functor (IOEnv m) where
  fmap  = liftM

instance Applicative (IOEnv m) where
  pure  = return
  (<*>) = ap

returnM :: a -> IOEnv env a
returnM a = IOEnv (StateT (\ env -> return (a, env)))

thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b
thenM (IOEnv m) f = IOEnv (StateT (\ env ->
                                     do (r, env') <- runStateT m env
                                        runStateT (unIOEnv (f r)) env'))

instance MonadIO (IOEnv m) where
  liftIO = liftIOM

liftIOM :: IO a -> IOEnv m a
liftIOM = IOEnv . liftIO


runIOEnv :: env -> IOEnv env a -> IO (a, env)
runIOEnv env (IOEnv m) = runStateT m env

evalIOEnv :: env -> IOEnv env a -> IO a
evalIOEnv env = liftM fst . runIOEnv env

execIOEnv :: env -> IOEnv env a -> IO env
execIOEnv env = liftM snd . runIOEnv env


getEnv :: IOEnv env env
getEnv = IOEnv get

setEnv :: env -> IOEnv env ()
setEnv env = IOEnv $ put env

localEnv :: (env -> env) -> IOEnv env a -> IOEnv env a
localEnv f do_this
  = do env <- getEnv
       setEnv (f env)
       r <- do_this
       setEnv env
       return r


<|start_filename|>backend/Inliner.hs<|end_filename|>
{- |
Module      :  Inliner
Description :  A simple heuristic inliner for FCore
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Yanlin <<EMAIL>>
Stability   :  experimental
Portability :  portable

This module implements a simple heuristic inlining process for FCore.
-}


module Inliner where

import OptiUtils
import Core

-- TODO: inline definitions inside module?
inliner :: Expr t (Expr t e) -> Expr t e
inliner (Var _ x) = x
inliner (Lam n t1 e1) = Lam n t1 (inliner . e1 . var)
inliner (App e1 e2) = App (inliner e1) (inliner e2)
inliner (BLam n t1) = BLam n (inliner . t1)
inliner (TApp e t) = TApp (inliner e) t
inliner (Lit s) = Lit s
inliner (If e1 e2 e3) = If (inliner e1) (inliner e2) (inliner e3)
inliner (PrimOp e1 o e2) = PrimOp (inliner e1) o (inliner e2)
inliner (Tuple es) = Tuple (map inliner es)
inliner (Proj i e) = Proj i (inliner e)
inliner (Fix n1 n2 f t1 t2) = Fix n1 n2 (\name n -> joinExpr $ f (joinExpr $ lam t1 (f (var name))) (var n)) t1 t2
inliner (LetRec n f es1 es2) =
  LetRec n f
         (map joinExpr . es1 . map joinExpr . es1 . map var)
         (joinExpr . es2  . map var)
inliner (JNew name es) = JNew name (map inliner es)
inliner (JMethod jc m es cn) =
  JMethod (fmap inliner jc) m (map inliner es) cn
inliner (JField jc fn cn) = JField (fmap inliner jc) fn cn
inliner (Seq es) = Seq (map inliner es)
inliner (Let n e body) = Let n (inliner e) (inliner . body . var)
inliner e = joinExpr e

-- current version cannot handle LetRec
recurNum :: Expr t Int -> Int
recurNum (Var _ x) = x
recurNum (Lit _) = 0
recurNum (Lam _ _ f) = recurNum $ f 0
recurNum (Fix _ _ f _ _) = recurNum $ f 1 0
recurNum (Let _ e f) = recurNum e + recurNum (f 0)
recurNum (LetRec _ _ f1 f2) = sum (map recurNum (f1 (repeat 0))) + recurNum (f2 (repeat 0))
recurNum (App e1 e2) = recurNum e1 + recurNum e2
recurNum (If e1 e2 e3) = recurNum e1 + recurNum e2 + recurNum e3
recurNum (PrimOp e1 _ e2) = recurNum e1 + recurNum e2
recurNum _ = 0


<|start_filename|>testsuite/CoreSpec.hs<|end_filename|>
module CoreSpec where

import Test.Hspec

import Core

-- `main` is here so that this module can be run from GHCi on its own.  It is
-- not needed for automatic spec discovery.
main :: IO ()
main = hspec spec

-- /\A. /\B. \(x : A). \(y : B). x
konst :: Expr Int Int
konst = bLam (\a -> bLam (\b ->
          lam (tVar a) (\x -> lam (tVar b) (\y -> var x))))

-- forall A. forall B. A -> B -> A
typeOfKonst :: Type Int
typeOfKonst = Core.forall (\a -> Core.forall (\b -> tVar a `Fun` (tVar b `Fun` tVar a)))

-- /\A. (x : A). x
ident :: Expr Int Int
ident = bLam (\a -> lam (tVar a) (\x -> var x))

spec :: Spec
spec =
  describe "*** Notice: Tests for `infer' is skipped" $ do
    return ()
    -- describe "type application" $ do
    --   mapM_ (\(name, input, expectedOutput) ->
    --     it ("should infer " ++ name) $ (show . infer) input `shouldBe` expectedOutput)
    --     [("konst", konst, "forall A. forall B. A -> B -> A")
    --     ,("konst Int", konst `TApp` javaInt, "forall B. Int -> B -> Int")
    --     ,("konst Int (Int & Int)", konst `TApp` javaInt `TApp` (javaInt `And` javaInt), "Int -> (Int & Int) -> Int")
    --     ,("konst typeOfKonst", konst `TApp` typeOfKonst, "forall B. (forall C. forall D. C -> D -> C) -> B -> (forall C. forall D. C -> D -> C)")
    --     ,("konst typeOfKonst typeOfKonst", konst `TApp` typeOfKonst `TApp` typeOfKonst, "(forall C. forall D. C -> D -> C) -> (forall C. forall D. C -> D -> C) -> (forall C. forall D. C -> D -> C)")
    --     ]

    -- describe "application" $ do
    --   mapM_ (\(name, input, expectedOutput) ->
    --     it ("should infer " ++ name) $ (show. infer) input `shouldBe` expectedOutput)
    --     [("(\\(x : Int). x) (ident ,, 1)", Lam javaInt (\x -> Var x) `App` (ident `Merge` Lit 1), "Int")]


<|start_filename|>backend/JavaEDSL.hs<|end_filename|>
-- | EDSL for Language-Java

module JavaEDSL where

import Language.Java.Syntax
import StringPrefixes

-- Type

arrayTy :: Type -> Type
arrayTy ty  = RefType (ArrayType ty)

classTy :: String -> Type
classTy t = RefType $ ClassRefType $ classTyp t

classTyp :: String -> ClassType
classTyp t = ClassType [(Ident t, [])]

intTy :: Type
intTy = PrimType IntT

closureType :: Type
closureType = classTy ifoClass

objClassTy :: Type
objClassTy = classTy "Object"

typeOfType :: Type
typeOfType = classTy typeHouse

-- var

name :: [String] -> Name
name xs = Name $ map Ident xs

var :: String -> Either Name Literal
var x = Left $ name [x]

varExp :: String -> Exp
varExp x = ExpName $ name [x]

varDecl :: String -> Exp -> VarDecl
varDecl nam e = VarDecl (VarId $ Ident nam) (Just $ InitExp e)

varDeclNoInit :: String -> VarDecl
varDeclNoInit nam = VarDecl (VarId $ Ident nam) Nothing

localVar :: Type -> VarDecl -> BlockStmt
localVar typ vard = LocalVars [] typ [vard]

localVarWithAnno :: Annotation -> Type -> VarDecl -> BlockStmt
localVarWithAnno anno typ vard = LocalVars [Annotation anno, Public] typ [vard]

localFinalVar :: Type -> VarDecl -> BlockStmt
localFinalVar typ vard = LocalVars [Final] typ [vard]

extractVar :: Either Name Literal -> String
extractVar x = case x of
                Left (Name xs) -> case head xs of
                                   Ident xs' -> xs'
                Right _ -> error "this should be a left (variable name)"

-- transform

block :: [BlockStmt] -> Block
block = Block

bStmt :: Stmt -> BlockStmt
bStmt = BlockStmt

expToBlockStmt :: Exp -> BlockStmt
expToBlockStmt = BlockStmt . ExpStmt

left :: Either Name Literal -> Exp
left (Left x) = ExpName x
left (Right _) = error "this should be left (variable name)"

right :: Either Name Literal -> Exp
right (Right x) = Lit x
right (Left _) = error "this should be right (literal or method inv)"

unwrap :: Either Name Literal -> Exp
unwrap x = case x of
            Left (Name xs) -> ExpName . Name $ xs
            Right e -> Lit e

localToMember :: BlockStmt -> Decl
localToMember (LocalClass t) = MemberDecl (MemberClassDecl t)
localToMember (LocalVars modi typ decls) = MemberDecl (FieldDecl modi typ decls)
localToMember b@(BlockStmt{}) = InitDecl True (Block [b])

makeStatic :: Decl -> Decl
makeStatic (MemberDecl (MemberClassDecl (ClassDecl modi i t r rs body)))
  = MemberDecl (MemberClassDecl (ClassDecl (Static : modi) i t r rs body))
makeStatic (MemberDecl (FieldDecl modi typ decls)) = MemberDecl (FieldDecl (Static : modi) typ decls)
makeStatic e = e

-- method

paramDecl :: Type -> String -> FormalParam
paramDecl t n = FormalParam [] t False (VarId (Ident n))

methodCallExp :: [String] -> [Argument] -> Exp
methodCallExp idents argu = MethodInv (MethodCall (name idents) argu)

methodCall :: [String] -> [Argument] -> Stmt
methodCall idents argu = ExpStmt (methodCallExp idents argu)

applyMethodCall :: Exp -> Stmt
applyMethodCall f = classMethodCall f "apply" []

applyCall :: BlockStmt
applyCall = bStmt $ methodCall ["apply"] []

classMethodCall :: Exp -> String -> [Argument] -> Stmt
classMethodCall e s argus = ExpStmt (MethodInv (PrimaryMethodCall e [] (Ident s) argus))

-- class construction

-- field member
fieldDecl :: Type -> VarDecl -> MemberDecl
fieldDecl typ vdecl = FieldDecl [] typ [vdecl]

finalFieldDecl :: Type -> VarDecl -> MemberDecl
finalFieldDecl typ vdecl = FieldDecl [Final] typ [vdecl]

-- class member
memberClassDecl :: String -> String -> ClassBody -> MemberDecl
memberClassDecl nam super body = MemberClassDecl (ClassDecl [] (Ident nam) [] (Just $ ClassRefType $ ClassType [(Ident super, [])]) [] body)

-- method member
methodDecl :: [Modifier] -> Maybe Type -> String -> [FormalParam] -> Maybe Block -> MemberDecl
methodDecl modi ty nam params body = MethodDecl modi [] ty (Ident nam) params [] (MethodBody body)

-- constructor
constructorDecl :: String -> [FormalParam] -> Maybe ExplConstrInv -> [BlockStmt] -> MemberDecl
constructorDecl nam params constrinv stmts = ConstructorDecl [] [] (Ident nam) params [] (ConstructorBody constrinv stmts)

-- for constructor: this.name = name
initField :: String -> BlockStmt
initField fieldname = let fieldaccess' = fieldAccExp This fieldname
                      in   assignField fieldaccess' (ExpName (name [fieldname]))

-- classbody
memberDecl :: MemberDecl -> Decl
memberDecl = MemberDecl

classBody :: [Decl] -> ClassBody
classBody = ClassBody

closureBodyGen :: [Decl] -> [BlockStmt] -> Int -> Bool -> Type -> ClassBody
closureBodyGen initDecls body idCF generateClone className = classBody $ initDecls ++ [applyMethod] ++ [cloneMethod | generateClone]
  where
    applyMethod = MemberDecl $ methodDecl [Public] Nothing "apply" [] (Just (Block body))
    cloneMethod = MemberDecl $ methodDecl [Public] (Just className) "clone" [] (Just cloneBody)
    cloneBody = block
                  [ localVar className (varDecl "c" (funInstCreate idCF))
                  ,
                  -- ,assign (name ["c", closureInput]) (ExpName $ name ["this", closureInput])
                  -- ,bStmt $ (applyMethodCall (left . var $ "c"))
                  bStmt (Return (Just (cast className (left $ var "c"))))
                  ]

-- class decl
localClassDecl :: String -> String -> ClassBody -> BlockStmt
localClassDecl nam super body = LocalClass (ClassDecl [] (Ident nam) [] (Just $ ClassRefType $ ClassType [(Ident super, [])]) [] body)

localClass :: String -> ClassBody -> BlockStmt
localClass nam body = LocalClass (ClassDecl [] (Ident nam) [] Nothing [] body)

classDecl :: [Modifier] -> String -> ClassBody -> ClassDecl
classDecl modi ident =
  ClassDecl modi (Ident ident) [] Nothing []

-- expression

-- lit
integerExp :: Integer -> Exp
integerExp = Lit . Int

stringExp :: String -> Exp
stringExp = Lit . String

nullExp :: Exp
nullExp = Lit Null

-- op
eq :: Exp -> Exp -> Exp
eq e1 = BinOp e1 Equal

-- type cast
cast :: Type -> Exp -> Exp
cast = Cast

-- class field access
fieldAccess :: Exp -> String -> Exp
fieldAccess expr str = FieldAccess $ PrimaryFieldAccess expr (Ident str)

fieldAccExp :: Exp -> String -> FieldAccess
fieldAccExp expr str = PrimaryFieldAccess expr (Ident str)

-- class instantiation
instCreat :: ClassType -> [Argument] -> Exp
instCreat cls args = InstanceCreation [] cls args Nothing

funInstCreate :: Int -> Exp
funInstCreate i = instCreat fun []
  where fun = ClassType [(Ident (closureTransName ++ show i),[])]

typeHouseCreate :: Exp
typeHouseCreate = instCreat fun []
  where
    fun = ClassType [(Ident typeHouse, [])]

-- assignment
bsAssign :: Name -> Exp -> BlockStmt
bsAssign lhs rhs = BlockStmt $ ExpStmt $ Assign (NameLhs lhs) EqualA rhs

assignE :: Name -> Exp -> Stmt
assignE lhs rhs = ExpStmt $ Assign (NameLhs lhs) EqualA rhs

assignField :: FieldAccess -> Exp -> BlockStmt
assignField access rhs = BlockStmt $ ExpStmt $ Assign (FieldLhs access) EqualA rhs

-- if
ifthen :: Exp -> Stmt -> Stmt
ifthen = IfThen

-- switch
switchStmt:: Exp -> [SwitchBlock] ->Stmt
switchStmt = Switch

switchBlock :: Maybe Exp -> [BlockStmt] -> SwitchBlock
switchBlock (Just e) bs = SwitchBlock (SwitchCase e) $ bs ++ [bStmt (Break Nothing)]
switchBlock Nothing  bs = SwitchBlock Default bs

-- return
returnNull :: Maybe Block
returnNull = Just (Block [BlockStmt (Return (Just (Lit Null)))])

returnExp :: Exp -> Maybe Block
returnExp e= Just (Block [BlockStmt (Return (Just e))])

returnExpS :: Exp -> BlockStmt
returnExpS e= BlockStmt (Return (Just e))

-- exception
throwRuntimeException :: String -> Stmt
throwRuntimeException s = Throw $ instCreat (classTyp "RuntimeException") [Lit. String $ s]

-- Main

mainArgType :: [FormalParam]
mainArgType = [paramDecl (arrayTy $ classTy "String") "args"]

mainBody :: Maybe Block
mainBody = Just (block [bStmt $ classMethodCall (left $ var "System.out")
                                                "println"
                                                [left $ var "apply()"]])

moduleMainBody :: Maybe Block
moduleMainBody = Just (block [bStmt $ classMethodCall (left $ var "System.out")
                                                "println"
                                                [Lit (String "Module generated")]])

wrapperClass :: Bool -> String -> [BlockStmt] -> Maybe Type -> Maybe Block -> TypeDecl
wrapperClass isModule className stmts returnType mainbodyDef =
  ClassTypeDecl
    (classDecl [Public] className
       (classBody
          (if isModule
             then defClasses ++ [mainMethod]
             else applyMethod : [mainMethod])))
  where
    body = Just (block stmts)
    applyMethod = memberDecl $ methodDecl [Static] returnType "apply" [] body
    defClasses = map (makeStatic . localToMember) stmts
    -- testMethod = memberDecl $ methodDecl [Public,Static] returnType "test" testArgType testBodyDef
    mainMethod = memberDecl $ methodDecl [Public, Static] Nothing "main" mainArgType mainbodyDef

annotation :: String -> Modifier
annotation ann = Annotation MarkerAnnotation {annName = Name [Ident ann]}

normalAnno :: String -> String -> String -> Annotation
normalAnno srcName genName sig =
  NormalAnnotation
    (name [annoName])
    [(Ident annoSrcName,EVVal (InitExp (Lit (String srcName))))
    ,(Ident annoGenName,EVVal (InitExp (Lit (String genName))))
    ,(Ident annoSig,EVVal (InitExp (Lit (String sig))))]


<|start_filename|>examples/case_studies/ParBalance.hs<|end_filename|>
{-# LANGUAGE TemplateHaskell #-}

module ParBalance where

--1 try "runTest" in the terminal to test all the properites, just a reminder, it won't stop.
--2 try "multiTest" to test "prop_reverse_reverse_equivalence" 10 times with time showed below

import Test.QuickCheck.All
import Test.QuickCheck
import Data.List
import qualified Data.Set as Set
import MonadLib
import System.CPUTime
import System.Timeout


openPar :: Int
openPar = 1
closePar :: Int
closePar = 2

--function "balanced"
balanced :: [Int] -> Int -> Bool
balanced l co = if co < 0
                then False
                else case l of [] -> co == 0
                               (h:t) -> balanced t c
                                  where c = if h == openPar
                                            then (co + 1)
                                            else if h == closePar
                                                 then (co - 1)
                                                 else co

--function "balanced_nonEarly"
balanced_nonEarly :: [Int] -> Int -> Bool
balanced_nonEarly l co =
      case l of [] -> co == 0
                (h:t) -> if co < 0
                         then balanced_nonEarly t co
                         else balanced_nonEarly t c
                               where c = if h == openPar then (co + 1)
                                         else if h == closePar
                                              then (co - 1)
                                              else co

----test for balanced_nonEarly
prop_balanced_nonEarly :: [Int] -> Int -> Bool
prop_balanced_nonEarly l c = balanced_nonEarly l c == balanced l c


--function "balanced_withFailure"
balanced_withFailure :: [Int] -> Int -> Bool -> Bool
balanced_withFailure l co fa
   | co >= 0 || fa =
       case l of [] -> not fa && co == 0
                 (h:t) -> balanced_withFailure t c (fa || c < 0)
                   where c = if h == openPar then (co + 1)
                                             else if h == closePar
                                                  then (co - 1)
                                                  else co

----test for balance_withFailure
prop_balance_withFailure :: [Int] -> Int -> Bool -> Property
prop_balance_withFailure l co fa = co >= 0 || fa ==>
     if fa then res == balanced_nonEarly l (-1)
           else res == balanced_nonEarly l co
             where res = balanced_withFailure l co fa



--function "balanced_withReduce"
balanced_withReduce :: [Int] -> (Int,Int) -> Bool
balanced_withReduce l p@(p1,p2)
 | p1 >= 0 && p2 >= 0 =
    case l of [] -> p1 == 0 && p2 == 0
              (h:t) -> balanced_withReduce t (reduce p (parPair h))
 | otherwise = error "pair is less then 0"

----test for balanced_withReduce
prop_balanced_withReduce :: [Int] -> (Int,Int) -> Property
prop_balanced_withReduce l (p1,p2) = p1 >= 0 && p2 >= 0 ==>
     balanced_withReduce l (p1,p2) ==
     balanced_withFailure l (p1 - p2) (p2 > 0)


--function "balanced_foldLeft_equivalence"
balanced_foldLeft_equivalence :: [Int] -> (Int,Int) -> Bool
balanced_foldLeft_equivalence l (p1,p2)
 | p1 >= 0 && p2 >= 0 =
   (foldl f (p1,p2) l == (0,0)) == balanced_withReduce l (p1,p2)
   && case l of [] -> True
                (h:t) -> balanced_foldLeft_equivalence t pp
                  where pp = f (p1,p2) h
 | otherwise = error " "
 where f = (\s-> \x -> reduce s (parPair x))

----test for balanced_foldLeft_equivalence
prop_balanced_foldLeft_equivalence :: [Int] -> (Int,Int) -> Property
prop_balanced_foldLeft_equivalence l (p1,p2) = p1 >= 0 && p2 >= 0 ==>
    balanced_foldLeft_equivalence l (p1,p2)



--function "reduce"
reduce :: (Int,Int) -> (Int,Int) -> (Int,Int)
reduce p1@(p11,p12) p2@(p21,p22) =
       if p11 >= p22 then ((p11 - p22 + p21), p12)
                     else (p21, (p22 - p11 + p12))


--property "reduce_associative"
prop_reduce_associative :: (Int,Int) -> (Int,Int) -> (Int,Int) -> Bool
prop_reduce_associative p1 p2 p3 = reduce p1 (reduce p2 p3) ==
                                   reduce (reduce p1 p2) p3


--function "swap"
swap :: (Int, Int) -> (Int, Int)
swap (p1,p2) = (p2,p1)


--property "reduce_inverse"
prop_reduce_inverse :: (Int,Int) -> (Int,Int) -> Bool
prop_reduce_inverse p1 p2 = reduce p1 p2 ==
                            swap (reduce (swap p2) (swap p1))


--property "reduce_associative_inverse"
prop_reduce_associative_inverse :: (Int,Int) -> (Int,Int) -> (Int,Int) -> Bool
prop_reduce_associative_inverse p1 p2 p3 =
         reduce p1 (reduce p2 p3) ==
         swap (reduce (reduce (swap p3) (swap p2)) (swap p1))


--property "reduce_associative_inverse2"
prop_reduce_associative_inverse2 :: (Int,Int) -> (Int,Int) -> (Int,Int) -> Bool
prop_reduce_associative_inverse2 p1 p2 p3 =
         reduce (reduce p1 p2) p3 ==
         swap (reduce (swap p3) (reduce (swap p2) (swap p1)))


--function "parPair"
parPair :: Int -> (Int,Int)
parPair x = if x == openPar then (1,0)
                            else if x == closePar then (0,1)
                                                  else (0,0)


--function "headOption"
headOption :: [Int] -> Maybe Int
headOption (h:t) = Just h
headOption [] = Nothing


--function "lastOption"
lastOption :: [Int] -> Maybe Int
lastOption [h] = Just h
lastOption (h:t) = lastOption t
lastOption [] = Nothing


--function "addLast"
addLast :: [Int] -> Int -> [Int]
addLast (h:t) x = (h:(addLast t x))
addLast [] x = [x]

--function "reversel" denoting reverese function using addLast
reversel :: [Int] -> [Int]
reversel (h:t) = addLast (reversel t) h
reversel [] = []

----test for reversel
prop_reversel :: [Int] -> Bool
prop_reversel l = lastOption res == headOption l
               && lastOption l == headOption res
                   where res = reversel l


----property "reverse_tail_equivalence"
prop_reverse_tail_equivalence :: [Int] -> Bool
prop_reverse_tail_equivalence [] = True
prop_reverse_tail_equivalence l =
     reversel (tail l) == init (reversel l)


----property "reverse_init_equivalence"
prop_reverse_init_equivalence :: [Int] -> Bool
prop_reverse_init_equivalence [] = True
prop_reverse_init_equivalence l= reversel (init l) == tail (reversel l)
                     && case l of [] -> True
                                  (h:t) -> prop_reverse_init_equivalence t


----property "reverse_equality_equivalence"
prop_reverse_equality_equivalence :: [Int] -> [Int] -> Bool
prop_reverse_equality_equivalence l1 l2 =
    (l1 == l2) == (reversel l1 == reversel l2) &&
    case l1 of (h1:t1) -> case l2 of (h2:t2) -> prop_reverse_equality_equivalence t1 t2
                                     l2 -> True
               l1 -> True


{- this property is commented becasue it can't stop, actually the below property has the same
   problem

prop_reverses :: [Int] -> Bool
prop_reverses l = reverse (reverse l) == l
    && case (l, (reverse l)) of ((h1:t1),(h2:t2)) -> prop_reverses t1 && prop_reverses t2
                                (l, l2) -> True
-}

----property "reverse_reverse_equivalence"
reverse_reverse_equivalence :: [Int] -> Bool
reverse_reverse_equivalence l = reversel (reversel l) == l
      && case (l, (reversel l)) of ((h1:t1),(h2:t2)) -> reverse_reverse_equivalence t1 && reverse_reverse_equivalence t2
                                   (l, l2) -> True



prop_reverse_reverse_equivalence :: Property
prop_reverse_reverse_equivalence =
  forAll shortList $ \l -> reverse_reverse_equivalence l

----short list data generator
shortList :: Gen [Int]
shortList = (take 15) `fmap` arbitrary





------------------------------timer------------------------------------
timeIt :: (Fractional c) => (a -> IO b) -> a -> IO c
timeIt action arg = do
       startTime <- getCPUTime
       action arg
       finishTime <- getCPUTime
       return $ fromIntegral (finishTime - startTime) / 1000000000

--timeIt' :: (Fractional c) => (a -> b) -> a -> IO c
--timeIt' f = timeIt (\x -> f x `seq` return())

oneTest = timeout 5000000 $ timeIt quickCheck prop_reverse_reverse_equivalence >>= print

multiTest = do
            startTime <- getCPUTime
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            oneTest
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000

----------------------------------------------------------------------




------for-quickCheck-test------
return []                    --
runTests = $quickCheckAll    --
-------------------------------












<|start_filename|>frontend/Config.hs<|end_filename|>
{- |
Module      :  Config
Description :  Compiler configurations.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module Config where

data IntersectionBias = LeftBiased | RightBiased

-- If a record contains more than one field with the same label, the first field
-- for the label is preferred. For example, `{ age = 3, age = 8 }.age` evaluates
-- to 3. This configuration should be consistent with the corresponding one in
-- the simplifier.
intersectionBias :: IntersectionBias
intersectionBias = LeftBiased


<|start_filename|>backend/Playground.hs<|end_filename|>
module Playground where

import           BackEnd (compileN, compileN2)
import qualified ClosureF as C
import           Core
import           Desugar (desugar)
import qualified OptiUtils (Exp(Hide))
import           Parser (parseExpr, P(..))
import           PartialEvaluator
import           Simplify (simplify)
import qualified Src as S
import           System.Exit
import qualified SystemFI as FI
import           TypeCheck (checkExpr)

import qualified Language.Java.Syntax as J (Op(..))
import           Language.Java.Pretty (prettyPrint)
import           Unbound.Generics.LocallyNameless

import qualified Syntax  as NC
import qualified PrettyPrint as PP

-- test1 :: Expr t e
-- test1 =
--   Lam "f" javaInt (\f -> Lam "g" javaInt (\g -> var f `add` var g))

core2java core = do
  let newcore = runFreshM (NC.core2New core)
  -- putStrLn "-- Core:"
  -- print (Core.prettyExpr core)
  putStrLn "-- NewCore:"
  putStrLn $ PP.showExpr newcore


s2Java core = do
  let newcore = runFreshM (NC.core2New core)
  let cu = compileN2 "test" newcore
  putStrLn $ prettyPrint cu


-- typeId :: CN.Expr e
-- typeId = CN.Lam "" CN.Star (\x -> CN.Var "" x)

-- -- (\ x : ⋆ . (\ y : x . y)) Int 3 + 3
-- testPoly :: CN.Expr e
-- testPoly = (CN.App
--                 (CN.App (CN.Lam "" CN.Star (\x -> CN.Lam "" (CN.Var "" x) (\y -> CN.Var "" y)))
--                    (CN.javaInt))
--                 (CN.Lit (S.Int 3))) `addn` (CN.Lit (S.Int 3))

-- -- (\x : (\ y : ⋆ . y) Int . x) (castup [(\ y : ⋆ . y) Int] 3)
-- testCastUp :: CN.Expr e
-- testCastUp = CN.App (CN.Lam "" (CN.App typeId (CN.JClass "java.lang.Integer")) (\x -> CN.Var "" x))
--                (CN.CastUp (CN.App typeId CN.javaInt) (CN.Lit (S.Int 3)))

-- -- (\e : (\y : ⋆ . x) Int . (\x : Int . x) (castdown e))
-- testCastDown :: CN.Expr e
-- testCastDown = CN.Lam "" (CN.App typeId CN.javaInt)
--                  (\e ->
--                     CN.App (CN.Lam "" CN.javaInt (\x -> CN.Var "" x)) (CN.CastDown CN.javaInt (CN.Var "" e)))

-- let x = Int in (\y : x . y) 3
-- testLet :: CN.Expr e
-- testLet = CN.Let "" CN.javaInt
--             (\x -> CN.App (CN.Lam "" (CN.Var "" x) (\y -> CN.Var "" y)) (CN.Lit (S.Int 3)))

-- pi x : * . x -> x
-- testPi :: CN.Expr e
-- testPi = CN.Pi "" (CN.Star) (\x -> CN.Pi "" (CN.Var "" x) (\y -> CN.Var "" x))


m1src = "package P.k module {rec even (n : Int) : Bool = if n == 0 then True  else odd  (n - 1) and odd  (n : Int) : Bool = if n == 0 then False else even (n - 1)} "

m2src = "import a.m; println \"hello\""

{-
module M1 {

rec even (n : Int) : Bool = if n == 0 then True  else odd  (n - 1)
and
odd  (n : Int) : Bool = if n == 0 then False else even (n - 1);

rec fact (n : Int) : Int = ...;

add (n : Int) (m : Int) = n + m

}

-}

-- m1 :: Expr t e
-- m1 = Module "_"
--        (DefRec
--           ["even", "odd"]
--           [ (S.Fun javaIntS javaBoolS, javaInt `Fun` javaBool)
--           , (S.Fun javaIntS javaBoolS, javaInt `Fun` javaBool)
--           ]
--           (\ids ->
--              [ lam javaInt
--                  (\n -> If (var n `eq` zero) true (App (var (ids !! 1)) (var n `sub` one)))
--              , lam javaInt
--                  (\n -> If (var n `eq` zero) false (App (var (ids !! 0)) (var n `sub` one)))
--              ])
--           (\ids ->
--              (Def "f1" (javaIntS `S.Fun` javaIntS) fact
--                 (\f1 ->
--                    Def
--                      "f2"
--                      (javaIntS `S.Fun` javaIntS)
--                      (lam javaInt (\n -> ((var f1 `App` (var n)) `add` one)))
--                      (\f2 -> Null)))))

-- New Core Test

s2c :: String -> IO ()
s2c source
  = case parseExpr source of
      ParseError msg -> do putStrLn msg
                           exitFailure
      ParseOk parsed -> do
        result <- checkExpr parsed
        case result of
          Left typeError -> exitFailure
          Right (_, checked) ->
            do let fiExpr = desugar checked
               let exp' = OptiUtils.Hide (simplify (FI.HideF fiExpr))
               let exp = rewriteAndEval exp'
               putStrLn "-- Core:"
               print (Core.prettyExpr exp)
               let expcn = runFreshM (NC.core2New exp)
               putStrLn "\n-- New Core:"
               putStrLn (PP.showExpr expcn)
               putStrLn ""

testnc :: IO ()
testnc =
  do
    -- s2c "let rec fact (n : Int) : Int = if n == 0 then 1 else n * fact (n - 1); fact 5"
    s2c "let id[A] (x : A) = x; id [forall A. A -> A] id 10"
    s2c "let get [D, E, F] (x : E) (y : D) : D = y; get [Int, String, Int] \"abc\" 5"
    return ()

testB :: String
testB = "(/\\B -> \\(f : B) -> f) [Int] 3"

testA :: String
testA = "if True then 1 else 2"

-- javaIntS = (S.JType (S.JClass "java.lang.Integer"))
-- javaBoolS = (S.JType (S.JClass "java.lang.Boolean"))


tailFact :: Expr t e
tailFact
  = fix (\tail_fact acc ->
      lam javaInt (\n ->
        If (var n `eq` zero)
           (var acc)
           (var tail_fact `App` (var acc `mult` var n) `App` (var n `sub` one))))
    javaInt (javaInt `Fun` javaInt)

testTail :: Expr t e
testTail = App (fix (\f n -> If (var n `eq` zero)
                           one
                           (var f `App` (var n `sub` one)))
               javaInt
               (javaInt `Fun` javaInt)) one

fact :: Expr t e
fact = App (fix (\f n -> If (var n `eq` zero)
                       one
                       (var n `mult` (var f `App` (var n `sub` one))))
           javaInt
           javaInt) one

testJNew :: String
testJNew = "let x = new java.lang.Integer(10) in x"

testJMethod = "let x = new java.lang.Integer(10) in x.toString()"

-- testLet :: String
-- testLet = "let id[A] (x : A) = x in id[Int] 5 + 1"

tailFactLike :: Expr t e
tailFactLike
  = fix (\tail_fact acc ->
      lam javaInt (\n ->
                    If (var n `eq` zero)
                    (var acc)
                    (var tail_fact `App` (var acc `mult` one) `App` one)))
    javaInt (javaInt `Fun` javaInt)


plus2 :: Expr t e
plus2 = (App (lam (Fun javaInt (Fun javaInt javaInt)) (\e -> (App (App (var e) one) zero)))
             (lam javaInt (\e -> (lam javaInt (\f -> (var e) `mult` (var f))))))

evenOdd :: Expr t e
evenOdd
  = LetRec
      ["even", "odd"]
      [(Fun javaInt javaBool), (Fun javaInt javaBool)]
      (\ids ->
         [ lam javaInt (\n -> If (var n `eq` zero) true  (App (var (ids !! 1)) (var n `sub` one)))
         , lam javaInt (\n -> If (var n `eq` zero) false (App (var (ids !! 0)) (var n `sub` one)))])
      (\ids ->
         App (var (ids !! 1)) magicNumber)


javaBool     = JClass "java.lang.Boolean"
zero         = Lit (S.Int 0)
one          = Lit (S.Int 1)
five         = Lit (S.Int 5)
ten          = Lit (S.Int 10)
negOne       = Lit (S.Int (-1))
magicNumber  = Lit (S.Int 42)
true         = Lit (S.Bool True)
false        = Lit (S.Bool False)
x `eq` y     = PrimOp x (S.Compare J.Equal) y
x `neq` y    = PrimOp x (S.Compare J.NotEq) y
x `lt` y     = PrimOp x (S.Compare J.LThan) y
x `bAnd` y    = PrimOp x (S.Logic J.And) y
x `add` y    = PrimOp x (S.Arith J.Add) y
x `sub` y    = PrimOp x (S.Arith J.Sub) y
x `mult` y   = PrimOp x (S.Arith J.Mult) y

-- x `addn` y    = CN.PrimOp x (S.Arith J.Add) y

mconst =
  (bLam (\a ->
    lam (tVar a) (\x ->
       lam (tVar a) (\y ->
          var x
       )
    )
  ))

notail2 =
  bLam (\a ->
    lam (Fun (tVar a) (Fun (tVar a) (tVar a))) (\f ->
      lam (tVar a) (\x ->
        lam (tVar a) (\y ->
          App (App (var f) (var x)) (App (App (var f) (var y)) (var y)) ))))

program2 = App (App (App (TApp notail2 (JClass "java.lang.Integer")) (TApp mconst (JClass "java.lang.Integer"))) (Lit (S.Int 5))) (Lit (S.Int 6))

notail4 =
  bLam (\a ->
    lam ( Fun (Fun (tVar a) (tVar a)) (Fun (Fun (tVar a) (tVar a)) (tVar a))) (\g ->
      lam (Fun (tVar a) (Fun (tVar a) (tVar a))) (\f ->
        lam (tVar a) (\x ->
          lam (tVar a) (\y ->
            App (App (var g) (App (var f) (var x))) (App (var f) (var y)))))))

summa =
    lam (Fun (JClass "java.lang.Integer") (JClass "java.lang.Integer")) (\x ->
       lam (Fun (JClass "java.lang.Integer") (JClass "java.lang.Integer")) (\y ->
          PrimOp (App (var x) (Lit (S.Int 0))) (S.Arith J.Add) (App (var y) (Lit (S.Int 0)))
       )
    )

program4 = App (App (App (App (TApp notail4 (JClass "java.lang.Integer")) summa) (TApp mconst (JClass "java.lang.Integer"))) (Lit (S.Int 5))) (Lit (S.Int 6))


<|start_filename|>frontend/FrontEnd.hs<|end_filename|>
module FrontEnd (source2core) where

import           BackEnd (DumpOption(..))
import           Desugar (desugar)
import qualified OptiUtils (Exp(Hide))
import           Parser (parseExpr, P(..))
import           Problem
import           Simplify (simplify)
import           SrcLoc
import qualified SystemFI as FI (FExp(HideF), prettyExpr)
import           TypeCheck (checkExpr)
import           TypeErrors

import           Control.Monad (when)
import           Data.List.Split (splitOn)
import           System.Exit (exitFailure)
import           Text.PrettyPrint.ANSI.Leijen hiding (line, column)

makeProblem :: (FilePath, String) -> Located TypeError -> Problem
makeProblem (filePath, source) (L loc err)
  = Problem
    { problemLevel    = Error
    , problemLocation = (filePath, line loc, column loc)
    , problemLine     = splitOn "\n" source !! (line loc - 1)
    , problemDescription = pretty err
    }

source2core :: DumpOption -> (FilePath, String) -> IO OptiUtils.Exp
source2core optDump (filePath, source)
  = case parseExpr source of
      ParseError msg -> do putStrLn msg
                           exitFailure
      ParseOk parsed -> do
        when (optDump == Parsed) $ print (pretty parsed)
        typeCheckResult <- checkExpr parsed
        case typeCheckResult of
          Left typeError ->
            do print (prettyProblems [makeProblem (filePath, source) typeError])
               exitFailure
          Right (_, checked) ->
            do when (optDump == TChecked) $ print (pretty checked)
               let fiExpr = desugar checked
               when (optDump == SystemFI) $ print (FI.prettyExpr fiExpr)
               return (OptiUtils.Hide (simplify (FI.HideF fiExpr)))


<|start_filename|>backend/ApplyTransCFJava.hs<|end_filename|>
{-# LANGUAGE RankNTypes, FlexibleInstances, FlexibleContexts, TypeOperators, MultiParamTypeClasses, ConstraintKinds, ScopedTypeVariables #-}
{- |
Module      :  ApplyTransCFJava
Description :  Translation of FCore to Java with Apply-opt
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Tomas <<EMAIL>>
Stability   :  experimental
Portability :  non-portable (MPTC)

This module augments the basic translation of FCore to Java with
multi-argument function optimization.
-}

module ApplyTransCFJava where
-- TODO: isolate all hardcoded strings to StringPrefixes (e.g. Fun)

import qualified Language.Java.Syntax as J

import           BaseTransCFJava
import           ClosureF
import           Inheritance
import           JavaEDSL
import           MonadLib
import           StringPrefixes

data ApplyOptTranslate m = NT {toT :: Translate m}

instance (:<) (ApplyOptTranslate m) (Translate m) where
   up              = up . toT

instance (:<) (ApplyOptTranslate m) (ApplyOptTranslate m) where
   up              = id

isMultiBinder :: EScope Int (Var, Type Int) -> Bool
isMultiBinder (Type _ _) = False
isMultiBinder (Kind _)   = True
isMultiBinder (Body _)   = True

-- main translation function
transApply :: (MonadState Int m,
               MonadReader Int m,
               MonadReader InitVars m,
               selfType :< ApplyOptTranslate m,
               selfType :< Translate m)
              => Mixin selfType (Translate m) (ApplyOptTranslate m)
transApply this super = NT {toT = super {

  translateM =
     \e -> case e of
              App e1 e2 -> do (n :: Int) <- ask
                              let flag = case e1 of Var _ _ -> True
                                                    _ -> False
                              translateApply (up this)
                                             flag
                                             (local (\(_ :: Int) -> n + 1) $ translateM (up this) e1)
                                             (local (\(_ :: Int) -> 0) $ translateM (up this) e2)
              _ -> translateM super e,

  genClosureVar =
    \flag arity j1 ->
     do (n :: Int) <- ask
        if flag && arity > n
          then return $ J.MethodInv (J.PrimaryMethodCall (unwrap j1) [] (J.Ident "clone") [])
          else return (unwrap j1),

  translateScopeTyp = \x1 f initVars nextInClosure m closureClass ->
    if isMultiBinder nextInClosure
    then do (initVars' :: InitVars) <- ask
            translateScopeTyp super x1 f (initVars ++ initVars') nextInClosure (local (\(_ :: InitVars) -> []) m) closureClass
    else do (s,je,t1) <- local (initVars ++) m
            let refactored = modifiedScopeTyp (unwrap je) s x1 f closureClass
            return (refactored,t1),

  genApply = \f t x y z ->
              do applyGen <- genApply super f t x y z
                 return [bStmt $ J.IfThen (fieldAccess f "hasApply") (J.StmtBlock (block applyGen))],

  genClone = return True
}}

modifiedScopeTyp :: J.Exp -> [J.BlockStmt] -> Int -> Int -> String -> [J.BlockStmt]
modifiedScopeTyp oexpr ostmts x1 f closureClass = completeClosure
  where closureType' = classTy closureClass
        currentInitialDeclaration = memberDecl $ fieldDecl closureType' (varDecl (localvarstr ++ show x1) J.This)
        setApplyFlag = assignField (fieldAccExp (left $ var (localvarstr ++ show x1)) "hasApply") (J.Lit (J.Boolean False))
        fc = f
        completeClosure = [localClassDecl (closureTransName ++ show fc) closureClass
                            (closureBodyGen
                             [currentInitialDeclaration, J.InitDecl False (block (setApplyFlag : ostmts ++ [bsAssign (name [closureOutput]) oexpr]))]
                             []
                             fc
                             True
                             closureType')]


-- Alternate version of transApply that works with Stack translation
transAS :: (MonadState Int m,
            MonadReader Int m,
            MonadReader Bool m,
            MonadReader InitVars m,
            selfType :< ApplyOptTranslate m,
            selfType :< Translate m)
           => Mixin selfType (Translate m) (ApplyOptTranslate m)
transAS this super = NT {toT = (up (transApply this super)) {

  translateM =
   \e -> case e of
            App e1 e2 -> do (n :: Int) <- ask
                            let flag = case e1 of Var _ _ -> True
                                                  _ -> False
                            translateApply (up this)
                                           flag
                                           (local (False &&) $ local (\ (_ :: Int) -> n + 1) (translateM (up this) e1))
                                           (local (False &&) $ local (\(_ :: Int) -> 0) (translateM (up this) e2))
            _ -> translateM super e,

  genApply = \f t tempOut outType z ->
    do applyGen <- genApply super f t tempOut outType z
       let tempDecl = localVar outType
                      (varDecl tempOut (case outType of
                                         J.PrimType J.IntT -> J.Lit (J.Int 0)
                                         _ -> J.Lit J.Null))
       let elseDecl = bsAssign (name [tempOut]) (cast outType (J.FieldAccess (fieldAccExp (cast z f) closureOutput)))

       if length applyGen == 2
         then return applyGen
         else return [tempDecl, bStmt $ J.IfThenElse (fieldAccess f "hasApply")
                                (J.StmtBlock (block applyGen))
                                (J.StmtBlock (block [elseDecl]))]
  }}


<|start_filename|>backend/newlib/PrettyPrint.hs<|end_filename|>
{-# LANGUAGE ViewPatterns #-}

module PrettyPrint (showExpr) where

import           Data.List (intersperse)
import qualified Language.Java.Pretty (prettyPrint)
import           Text.PrettyPrint.ANSI.Leijen (Doc, (<+>), (<>), text, dot, colon)
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import           Unbound.Generics.LocallyNameless


import qualified Src as S
import           Syntax


class Pretty p where
  ppr :: (Applicative m, LFresh m) => p -> m Doc

instance Pretty Expr where
  ppr (Var x) = return . text . show $ x
  ppr (App e es) = PP.parens <$> ((<+>) <$> ppr e <*> (ppr es))
  ppr (Lam bnd) = lunbind bnd $ \(delta, b) -> do
    delta' <- ppr delta
    b' <- ppr b
    return (PP.parens $ text "λ" <> delta' <+> dot <+> b')
  ppr (Star) = return $ PP.char '★'
  ppr (Pi bnd) = lunbind bnd $ \(delta, b) -> do
    let Cons bb = delta
    let ((x, Embed t), bb') = unrebind bb
    b' <- ppr b
    if (head (show x) == '_' && isEmpty bb')
      then do
        t' <- ppr t
        return (PP.parens $ t' <+> text "→" <+> b')
      else do
        delta' <- ppr delta
        return (PP.parens $ text "Π" <> delta' <+> dot <+> b')
  ppr (Mu b) = lunbind b $ \((x, Embed t), e) -> do
    t' <- ppr t
    e' <- ppr e
    return (PP.parens $ text "μ" <+> (text . show $ x) <+> colon <+> t' <+> dot <+> e')
  ppr (F t e) = do
    e' <- ppr e
    t' <- ppr t
    return (text "cast↑" <> PP.brackets t' <+> e')
  ppr (U e) = (text "cast↓" <+>) <$> ppr e
  ppr (Let bnd) = lunbind bnd $ \((x, Embed e1), e2) -> do
    e1' <- ppr e1
    e2' <- ppr e2
    return (text "let" <+> (text . show $ x) <+> PP.equals <+> e1' PP.<$> text "in" PP.<$> e2')
  ppr (LetRec bnd) = lunbind bnd $ \((unrec -> binds, body)) -> do
    binds' <- mapM
                (\(n, Embed t, Embed e) -> do
                   e' <- ppr e
                   t' <- ppr t
                   return (text (show n) <+> PP.colon <+> t' PP.<$> (PP.indent 2 (PP.equals <+> e'))))
                binds
    body' <- ppr body
    return $ text "let" <+> text "rec" PP.<$>
                            PP.vcat (intersperse (text "and") (map (PP.indent 2) binds')) PP.<$>
                            text "in" PP.<$>
                            body'
  ppr (If g e1 e2) = do
    g' <- ppr g
    e1' <- ppr e1
    e2' <- ppr e2
    return (text "if" <+> g' <+> text "then" <+> e1' <+> text "else" <+> e2')
  ppr (Lit (S.Int n)) = return $ PP.integer n
  ppr (Lit (S.String s)) = return $ PP.dquotes (PP.string s)
  ppr (Lit (S.Bool b)) = return $ PP.bool b
  ppr (Lit (S.Char c)) = return $ PP.char c
  ppr (Lit (S.UnitLit)) = return $ text "()"
  ppr (PrimOp op e1 e2) = do
    e1' <- ppr e1
    e2' <- ppr e2
    return $ PP.parens (e1' <+> op' <+> e2')

    where
      op' = text (Language.Java.Pretty.prettyPrint java_op)
      java_op =
        case op of
          S.Arith op'   -> op'
          S.Compare op' -> op'
          S.Logic op'   -> op'
  ppr Unit = return $ text "Unit"
  ppr (JClass "java.lang.Integer")   = return $ text "Int"
  ppr (JClass "java.lang.String")    = return $ text "String"
  ppr (JClass "java.lang.Boolean")   = return $ text "Bool"
  ppr (JClass "java.lang.Character") = return $ text "Char"
  ppr (JClass c)                     = return $ text c
  ppr (JNew c args)                  = do
    args' <- mapM ppr args
    return (text "new" <+> text c <> PP.parens (PP.cat $ PP.punctuate PP.comma args'))
  ppr (JMethod rcv mname args _)     = do
    args' <- mapM ppr args
    c <- case rcv of Left cn -> return $ text cn
                     Right e -> ppr e
    return (c <> dot <> text mname <> PP.parens (PP.cat $ PP.punctuate PP.comma args'))
  ppr (JField rcv fname _)           = do
    c <- case rcv of Left cn -> return $ text cn
                     Right e -> ppr e
    return (c <> dot <> text fname)
  ppr (Tuple t)                      = do
    t' <- mapM ppr t
    return $ PP.parens $ PP.cat $ PP.punctuate PP.comma t'
  ppr (Proj i t)                     = do
    t' <- ppr t
    return $ t' <> dot <> text (show i)
  ppr (Seq es)                       = do
    es' <- mapM ppr es
    return $ PP.vcat es'
  ppr (Product ts)                   = do
    ts' <- mapM ppr ts
    return $ PP.parens $ PP.cat $ PP.punctuate PP.comma ts'

  ppr (Sum bnd) = lunbind bnd $ \((x, Embed t), e) -> do
    t' <- ppr t
    e' <- ppr e
    return (PP.parens $ text "Σ" <+> (text . show $ x) <+> colon <+> t' <+> dot <+> e')

  ppr (Pack (e1, e2) t) = do
    e1' <- ppr e1
    e2' <- ppr e2
    t' <- ppr t
    return $ text "pack" <+> (PP.parens $ e1' <+> PP.comma <+> e2') <+> text "as" <+> t'

  ppr (UnPack (e1, e2) e3 e4) = do
    e1' <- ppr e1
    e2' <- ppr e2
    e3' <- ppr e3
    e4' <- ppr e4
    return $ text "unpack" <+>
             (PP.parens e1' <+> PP.comma <+> e2') <+>
             PP.equals <+>
             e3' <+>
             text "in" <+>
             e4'

instance Pretty Tele where
  ppr Empty = return PP.empty
  ppr (Cons bnd) = do
    t' <- ppr t
    bnd' <- ppr b'
    return ((PP.parens $ (text . show $ x) <+> colon <+> t') <> bnd')

    where
      ((x, Embed t), b') = unrebind bnd

showExpr :: Expr -> String
showExpr = show . runLFreshM . ppr

isEmpty :: Tele -> Bool
isEmpty Empty = True
isEmpty _ = False


<|start_filename|>frontend/typecheck/JvmTypeQuery.hs<|end_filename|>
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}

module JvmTypeQuery
  ( Connection -- Hide data constructors
  , withConnection
  , definedClass
  , definedConstructor
  , findMethodReturnType
  , findFieldType
  , getModuleInfo
  , extractModuleInfo
  , ModuleInfo(..)
  ) where

import JavaUtils (ClassName, MethodName, FieldName, ModuleName)
import RuntimeProcessManager (withRuntimeProcess)
import Src (Type, PackageName)
import StringUtils

import Control.Exception
import Data.Char (isSpace, toLower)
import Data.List
import Data.List.Split
import Data.Maybe (listToMaybe)
import System.Directory
import System.FilePath
import System.IO
import System.Process.Extra (system_)

data Connection = Connection
  { -- private
    _toHandle   :: Handle
  , _fromHandle :: Handle
  }

data ModuleInfo = ModuleInfo {
  minfoName :: String,  -- source name
  minfoGname :: String, -- java variable name
  minfoSignature :: Type } deriving (Show)

withConnection :: (Connection -> IO a)
               -> IO a
withConnection action
  = withRuntimeProcess "TypeServer" NoBuffering (\(toHandle, fromHandle) ->
      action Connection { _toHandle = toHandle, _fromHandle = fromHandle }
    )

sendRecv :: Connection -> [String] -> IO String
sendRecv conn args =
  do hPutStrLn (_toHandle conn) (unwords args)
     hGetLine (_fromHandle conn)

fixRet :: String -> IO (Maybe String)
fixRet "$" = return Nothing
fixRet str = return (Just str)

isTrue :: String -> Bool
isTrue s = (map toLower . filter (not . isSpace)) s == "true"

definedClass :: Connection -> ClassName -> IO Bool
definedClass conn c = isTrue <$> sendRecv conn ["qType", c]

definedConstructor :: Connection -> ClassName -> [ClassName] -> IO Bool
definedConstructor conn c params
  = isTrue <$> sendRecv conn (["qConstructor", c] ++ params)

findMethodReturnType
  :: Connection
  -> ClassName
  -> (Bool, MethodName)   -- True <=> static method
  -> [ClassName]          -- Class of the arguments
  -> IO (Maybe ClassName)
findMethodReturnType conn c (is_static, m) args
  = sendRecv conn ([tag, c, m] ++ args) >>= fixRet
  where
    tag = if is_static
             then "qStaticMethod"
             else "qMethod"

findFieldType
  :: Connection
  -> ClassName
  -> (Bool, FieldName)    -- True <=> static field
  -> IO (Maybe ClassName)
findFieldType conn c (is_static, f)
  = sendRecv conn [tag, c, f] >>= fixRet
  where
    tag = if is_static
             then "qStaticField"
             else "qField"

getModuleInfo :: Connection
              -> (Maybe Src.PackageName, ModuleName)
              -> IO (Maybe ([ModuleInfo], ModuleName))
getModuleInfo h (p, m) = do
  s <- sendRecv h ["qModuleInfo", ((maybe "" (++ ".") p) ++ capitalize m)] >>= fixRet
  case s of
    Nothing -> return Nothing
    Just xs -> return $ (maybe Nothing (Just . (,m)) (listToModuleInfo (splitOn "$" (init xs))))

  where
    maybeRead = fmap fst . listToMaybe . reads
    listToModuleInfo [] = return []
    listToModuleInfo (x:y:z:xs) = do
      xs' <- listToModuleInfo xs
      ty' <- maybeRead z :: Maybe Type
      return $ ModuleInfo x y ty' : xs'
    listToModuleInfo _ = Nothing


extractModuleInfo :: Connection
                  -> (Maybe Src.PackageName, ModuleName)
                  -> IO (Maybe ([ModuleInfo], ModuleName))
-- Compile imported modules if not compiled already
extractModuleInfo h (p, m) = do
  currDir <- getCurrentDirectory
  maybeExistClass <- getModuleInfo h (p, m)
  case maybeExistClass of
    Nothing -> do
      let moduleDir = maybe "" (\name -> currDir </> intercalate [pathSeparator] (splitOn "." name)) p
      res <- (try . system_ $ "f2j --compile --silent " ++ moduleDir </> m ++ ".sf") :: IO (Either SomeException ())
      either (const (return Nothing)) (const (getModuleInfo h (p, m))) res
    _ -> return maybeExistClass

-- Tests inteneded to be run by `runhaskell`

main :: IO ()
main = withConnection (\conn ->
  do definedClass conn "java.lang.String" >>= print
     definedClass conn "java.lang.Foo"  >>= print
     definedConstructor conn "java.lang.String" [] >>= print
     definedConstructor conn "java.lang.String" ["java.lang.String"] >>= print
     definedConstructor conn "java.lang.String" ["Foo"] >>= print
     findMethodReturnType conn "java.lang.String" (False, "concat") ["java.lang.String"] >>= print
     findMethodReturnType conn "java.lang.String" (False, "length") [] >>= print
     findMethodReturnType conn "java.lang.String" (True, "valueOf") ["java.lang.Integer"] >>= print
     findMethodReturnType conn "java.lang.String" (True, "valueOf") ["Foo"] >>= print
  )


<|start_filename|>testsuite/Test.hs<|end_filename|>

import Test.Tasty
import Test.Tasty.Hspec

import ModuleSpec
import TransCFSpec (transSpec)
import TypeCheckSpec (tcSpec)

main :: IO ()
main = do
  tcTests <- testSpec "Typecheck" tcSpec
  transTests <- testSpec "Translations" transSpec
  let tests = testGroup "fcore tests" [tcTests, transTests]
  defaultMain tests


<|start_filename|>frontend/StringUtils.hs<|end_filename|>
{- |
Module      :  StringUtils
Description :  Utilities for string operations.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module StringUtils
  ( capitalize
  ) where

import qualified Data.Char as Char (toUpper)

capitalize :: String -> String
capitalize "" = ""
capitalize (s:ss) = Char.toUpper s : ss


<|start_filename|>backend/MonadLib.hs<|end_filename|>
{-# OPTIONS -XMultiParamTypeClasses -XFlexibleInstances -XRankNTypes -XTypeOperators #-}

module MonadLib (module MonadLib, module Control.Monad, module Data.Monoid) where

import Control.Monad
import Data.Monoid
import Control.Applicative

-- Interfaces for various types of effects:

class (Monad m) => MonadState s m where
    get :: m s
    put :: s -> m ()

class Monad m => MonadReader r m where
    ask   :: m r
    local :: (r -> r) -> m a  -> m a
    reader :: (r -> a) -> m a
    reader f = do
      r <- ask
      return (f r)

class (Monoid w, Monad m) => MonadWriter w m where
    tell   :: w -> m ()
    listen :: m a -> m (a, w)
    pass   :: m (a, w -> w) -> m a

-- Monad Transformers

class MonadTrans t where
    lift :: Monad m => m a -> t m a

-- Reader Monad/Monad Transformers

asks :: MonadReader r m => (r -> a) -> m a
asks = reader

{-
instance MonadReader r ((->) r) where
    ask       = id
    local f m = m . f
    reader    = id
-}

newtype Reader r a = Reader {runReader :: r -> a}

mapReader :: (a -> b) -> Reader r a -> Reader r b
mapReader f m = Reader $ f . runReader m

withReader :: (r' -> r) -> Reader r a -> Reader r' a
withReader f m = Reader $ runReader m . f

instance Functor (Reader r) where
    fmap f m = Reader $ \r -> f (runReader m r)

instance Monad (Reader r) where
    return a = Reader $ \_ -> a
    m >>= k  = Reader $ \r -> runReader (k (runReader m r)) r

instance Applicative (Reader r) where
    pure  = return
    (<*>) = ap

instance {-# OVERLAPPING #-} MonadReader r (Reader r) where
    ask       = Reader id
    local f m = Reader $ runReader m . f

newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }

mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b
mapReaderT f m = ReaderT $ f . runReaderT m

withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT f m = ReaderT $ runReaderT m . f

instance (Monad m) => Functor (ReaderT r m) where
    fmap f m = ReaderT $ \r -> do
        a <- runReaderT m r
        return (f a)

instance (Monad m) => Applicative (ReaderT r m) where
    pure  = return
    (<*>) = ap

instance (Monad m) => Monad (ReaderT r m) where
    return a = ReaderT $ \_ -> return a
    m >>= k  = ReaderT $ \r -> do
        a <- runReaderT m r
        runReaderT (k a) r
    fail msg = ReaderT $ \_ -> fail msg

instance (MonadPlus m) => MonadPlus (ReaderT r m) where
    mzero       = ReaderT $ \_ -> mzero
    m `mplus` n = ReaderT $ \r -> runReaderT m r `mplus` runReaderT n r

instance (Monad m, MonadPlus m) => Alternative (ReaderT r m) where
    (<|>) = mplus
    empty = mzero

instance {-# OVERLAPPING #-} (Monad m) => MonadReader r (ReaderT r m) where
    ask       = ReaderT return
    local f m = ReaderT $ \r -> runReaderT m (f r)

instance {-# OVERLAPPING #-} MonadReader r m => MonadReader r (ReaderT t m) where
    ask       = ReaderT (\_ -> ask)
    local f m = ReaderT (\r -> local f (runReaderT m r))

-- State monad/monad transformers

modify :: (MonadState s m) => (s -> s) -> m ()
modify f = do
    s <- get
    put (f s)

gets :: (MonadState s m) => (s -> a) -> m a
gets f = do
    s <- get
    return (f s)

newtype State s a = State { runState :: s -> (a, s) }

evalState :: State s a -> s  -> a
evalState m s = fst (runState m s)

execState :: State s a -> s -> s
execState m s = snd (runState m s)

mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f m = State $ f . runState m

withState :: (s -> s) -> State s a -> State s a
withState f m = State $ runState m . f

instance Functor (State s) where
    fmap f m = State $ \s -> case runState m s of
                                 (a, s') -> (f a, s')

instance Monad (State s) where
    return a = State $ \s -> (a, s)
    m >>= k  = State $ \s -> case runState m s of
                                 (a, s') -> runState (k a) s'

instance Applicative (State s) where
    pure  = return
    (<*>) = ap

instance MonadState s (State s) where
    get   = State $ \s -> (s, s)
    put s = State $ \_ -> ((), s)

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }

evalStateT :: (Monad m) => StateT s m a -> s -> m a
evalStateT m s = do
    (a, _) <- runStateT m s
    return a

execStateT :: (Monad m) => StateT s m a -> s -> m s
execStateT m s = do
    (_, s') <- runStateT m s
    return s'

mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT f m = StateT $ f . runStateT m

withStateT :: (s -> s) -> StateT s m a -> StateT s m a
withStateT f m = StateT $ runStateT m . f

instance (Monad m) => Functor (StateT s m) where
    fmap f m = StateT $ \s -> do
        (x, s') <- runStateT m s
        return (f x, s')

instance (Monad m) => Monad (StateT s m) where
    return a = StateT $ \s -> return (a, s)
    m >>= k  = StateT $ \s -> do
        (a, s') <- runStateT m s
        runStateT (k a) s'
    fail str = StateT $ \_ -> fail str

instance (Monad m) => Applicative (StateT s m) where
    pure  = return
    (<*>) = ap

instance (MonadPlus m) => MonadPlus (StateT s m) where
    mzero       = StateT $ \_ -> mzero
    m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s

instance (Monad m, MonadPlus m) => Alternative (StateT s m) where
    (<|>) = mplus
    empty = mzero

instance (Monad m) => MonadState s (StateT s m) where
    get   = StateT $ \s -> return (s, s)
    put s = StateT $ \_ -> return ((), s)

instance MonadState s m => MonadState s (StateT t m) where
    get   = StateT $ \s -> liftM (\x -> (x,s)) get
    put s = StateT $ \s1 -> liftM (\x -> (x,s1)) (put s)

-- Writer monad/monad transformer

listens :: (MonadWriter w m) => (w -> b) -> m a -> m (a, b)
listens f m = do
    ~(a, w) <- listen m
    return (a, f w)

censor :: (MonadWriter w m) => (w -> w) -> m a -> m a
censor f m = pass $ do
    a <- m
    return (a, f)

newtype Writer w a = Writer { runWriter :: (a, w) }

execWriter :: Writer w a -> w
execWriter m = snd (runWriter m)

mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
mapWriter f m = Writer $ f (runWriter m)

instance Functor (Writer w) where
    fmap f m = Writer $ case runWriter m of
                            (a, w) -> (f a, w)

instance (Monoid w) => Monad (Writer w) where
    return a = Writer (a, mempty)
    m >>= k  = Writer $ case runWriter m of
                            (a, w) -> case runWriter (k a) of
                                (b, w') -> (b, w `mappend` w')

instance (Monoid w) => Applicative (Writer w) where
    pure  = return
    (<*>) = ap

instance (Monoid w) => MonadWriter w (Writer w) where
    tell   w = Writer ((), w)
    listen m = Writer $ case runWriter m of
                            (a, w) -> ((a, w), w)
    pass   m = Writer $ case runWriter m of
                            ((a, f), w) -> (a, f w)

newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }

execWriterT :: Monad m => WriterT w m a -> m w
execWriterT m = do
    (_, w) <- runWriterT m
    return w

mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT f m = WriterT $ f (runWriterT m)

instance (Monad m) => Functor (WriterT w m) where
    fmap f m = WriterT $ do
        (a, w) <- runWriterT m
        return (f a, w)

instance (Monoid w, Monad m) => Monad (WriterT w m) where
    return a = WriterT $ return (a, mempty)
    m >>= k  = WriterT $ do
        (a, w)  <- runWriterT m
        (b, w') <- runWriterT (k a)
        return (b, w `mappend` w')
    fail msg = WriterT $ fail msg

instance (Monoid w, Monad m) => Applicative (WriterT w m) where
    pure  = return
    (<*>) = ap

instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
    mzero       = WriterT mzero
    m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n

instance (Monoid w, Monad m, MonadPlus m) => Alternative (WriterT w m) where
    (<|>) = mplus
    empty = mzero

instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
    tell   w = WriterT $ return ((), w)
    listen m = WriterT $ do
        (a, w) <- runWriterT m
        return ((a, w), w)
    pass   m = WriterT $ do
        ((a, f), w) <- runWriterT m
        return (a, f w)

instance (MonadWriter w m, Monoid t) => MonadWriter w (WriterT t m) where
    tell   w = WriterT $ liftM (\x -> (x,mempty)) $ tell w
    listen m = WriterT $ liftM (\((x,y),z) -> ((x,z),y)) $ listen (runWriterT m)
    pass   m = WriterT $ pass $ liftM (\(((x,f),t)) -> (((x,t),f))) $ runWriterT m

-- Transformers:

instance MonadTrans (ReaderT r) where
    lift m = ReaderT $ \_ -> m

instance MonadTrans (StateT s) where
    lift m = StateT $ \s -> do
        a <- m
        return (a, s)

instance (Monoid w) => MonadTrans (WriterT w) where
    lift m = WriterT $ do
        a <- m
        return (a, mempty)

-- Interaction between effects:

instance (MonadState s m) => MonadState s (ReaderT r m) where
    get = lift get
    put = lift . put

instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where
    tell     = lift . tell
    listen m = ReaderT $ \w -> listen (runReaderT m w)
    pass   m = ReaderT $ \w -> pass   (runReaderT m w)

instance {-# OVERLAPPING #-} (MonadReader r m) => MonadReader r (StateT s m) where
    ask       = lift ask
    local f m = StateT $ \s -> local f (runStateT m s)

instance (MonadWriter w m) => MonadWriter w (StateT s m) where
    tell     = lift . tell
    listen m = StateT $ \s -> do
        ((a, s'), w) <- listen (runStateT m s)
        return ((a, w), s')
    pass   m = StateT $ \s -> pass $ do
        ((a, f), s') <- runStateT m s
        return ((a, s'), f)

instance {-# OVERLAPPING #-} (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
    ask       = lift ask
    local f m = WriterT $ local f (runWriterT m)

instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
    get = lift get
    put = lift . put

-- We need views to support multiple monads of the same type

data n :-> m = View {
  fromV :: forall a . n a -> m a,
  toV :: forall a . m a -> n a
  }

-- auxiliary definitions with views

getV :: MonadState s n => (n :-> m) -> m s
getV view = fromV view get

putV :: MonadState s n => (n :-> m) -> s -> m ()
putV view x = fromV view (put x)

localV :: MonadReader r n => (n :-> m) -> (r -> r) -> m a -> m a
localV view f ma = fromV view $ local f (toV view ma)



<|start_filename|>backend/BackEnd.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts
           , FlexibleInstances
           , KindSignatures
           , MultiParamTypeClasses
           , RankNTypes
           #-}

{-# OPTIONS_GHC -fno-warn-unused-binds -fwarn-incomplete-patterns -fno-warn-orphans #-}

module BackEnd
    ( Compilation
    , compileN
    , compileN2
    , compileAO
    , compileS
    -- , compileSAU
    , compileSN
    -- , compileUnbox
    -- , compileAoptUnbox
    -- , compileSU
    , core2java
    , picore2java
    , DumpOption(..)
    ) where

import           Unbound.Generics.LocallyNameless
import qualified Control.Monad.Reader as R

import           ApplyTransCFJava
import qualified BaseTrans as NB
import qualified BaseTransCFJava as OB
import qualified ClosureF
import qualified Core
import           Inheritance
import           Inliner
import           JavaUtils (ClassName)
import           MonadLib
import           OptiUtils
import           PartialEvaluator
import           PrettyPrint
import           PrettyUtils
import           StackTransCFJava
import qualified Syntax as NC
import           TransEnvironment (Context, initialEnv)
-- import           UnboxTransCFJava

import           Language.Java.Pretty
import qualified Language.Java.Syntax as J
import           Prelude hiding (exp)


data DumpOption
  = NoDump
  | Parsed
  | TChecked
  | SystemFI
  | SimpleCore
  | ClosureF
    deriving (Eq, Show)

-- Naive translation

naive :: MonadState Int m => OB.Translate m
naive = new OB.trans

naiveN :: (Fresh m, R.MonadReader Context m) => NB.Translate m
naiveN = new NB.trans

-- Apply naive optimization

applyopt :: (MonadState Int m, MonadReader Int m, MonadReader OB.InitVars m) => ApplyOptTranslate m
applyopt = new (transApply $> OB.trans)

-- Stack naive optimization

stackNaive :: (MonadState Int m, MonadReader Bool m) => TranslateStack m
stackNaive = new (transS $> OB.trans)

-- Unbox naive translation

-- unboxopt :: (MonadState Int m, MonadReader (Int, Bool) m) => UnboxTranslate m
-- unboxopt = new (transUnbox $> trans)


-- Stack/Apply/Unbox translation

adaptApply :: forall (m :: * -> *) t t1.
              (t -> t1 -> ApplyOptTranslate m) -> t -> t1 -> OB.Translate m
adaptApply mix' this super = toT $ mix' this super

adaptStack :: forall (m :: * -> *) t t1.
              (t -> t1 -> TranslateStack m) -> t -> t1 -> OB.Translate m
adaptStack mix' this super = toTS $ mix' this super

-- adaptUnbox :: forall (m :: * -> *) t t1.
--               (t -> t1 -> UnboxTranslate m) -> t -> t1 -> Translate m
-- adaptUnbox mix' this super = toUT $ mix' this super

-- Stack + Apply + Naive

stackApplyNew :: (MonadState Int m, MonadReader Int m, MonadReader Bool m, MonadReader OB.InitVars m) => ApplyOptTranslate m
stackApplyNew = new ((transAS <.> adaptStack transSA) $> OB.trans)

-- Apply + Unbox + Naive
-- applyUnbox :: (MonadState Int m, MonadReader (Int, Bool) m, MonadReader InitVars m) => ApplyOptTranslate m
-- applyUnbox = new ((transApply <.> adaptUnbox transUnbox) $> trans)

-- Stack + Unbox + Naive
-- stackUnbox :: (MonadState Int m, MonadReader (Int, Bool) m) => TranslateStack m
-- stackUnbox = new ((transSU <.> adaptUnbox transUnbox) $> trans)

-- Stack + Apply + Unbox + Naive
-- stackApplyUnbox :: (MonadState Int m, MonadReader (Int, Bool) m, MonadReader InitVars m) => ApplyOptTranslate m
-- stackApplyUnbox = new ((transAS <.> adaptStack transSAU <.> adaptUnbox transUnbox) $> trans)

instance (:<) (TranslateStack m) (ApplyOptTranslate m) where
  up = NT . toTS

instance (:<)  (ApplyOptTranslate m) (TranslateStack m) where
  up = TS . toT

-- instance (:<) (UnboxTranslate m) (TranslateStack m) where
--   up = TS . toUT

-- instance (:<) (TranslateStack m) (UnboxTranslate m) where
--   up = UT . toTS

-- instance (:<) (UnboxTranslate m) (ApplyOptTranslate m) where
--   up = NT . toUT

-- instance (:<) (ApplyOptTranslate m) (UnboxTranslate m) where
--   up = UT . toT

-- instance (:<) (BenchGenTranslateOpt m) (ApplyOptTranslate m) where
--   up = NT . toTBA

-- instance (:<) (BenchGenTranslateStack m) (TranslateStack m) where
--   up = TS . toTBS

-- instance (:<) (BenchGenTranslateStackOpt m) (ApplyOptTranslate m) where
--   up = NT . toTBSA

-- instance (:<) (BenchGenTranslateStackOpt m) (TranslateStack m) where
--   up = TS . toTBSA

-- instance (:<) (BenchGenTranslateStackOpt m) (UnboxTranslate m) where
--   up = UT . toTBSA

-- prettyJ :: Language.Java.Pretty.Pretty a => a -> IO ()
-- prettyJ = putStrLn . prettyPrint

-- | Core expression to Java.
core2java :: Bool -> Bool -> DumpOption -> Compilation -> ClassName -> Exp -> IO String
core2java supernaive optInline optDump compilation className closedCoreExpr =
  do let rewrittenCore = rewriteAndEval closedCoreExpr
     let recurNumOfCore =
           if optInline  -- inline
              then recurNum rewrittenCore
              else 0
     let inlineNum =
           if recurNumOfCore > 2
              then 0
              else recurNumOfCore
     let inlinedCore =
           case inlineNum of
             1 -> inliner rewrittenCore
             2 -> inliner . inliner $ rewrittenCore
             _ -> rewrittenCore
     when (optDump == SimpleCore) $
       print (Core.prettyExpr rewrittenCore)
     when (optDump == ClosureF) $
       print (ClosureF.prettyExpr basePrec
                                  (0,0)
                                  (ClosureF.fexp2cexp inlinedCore))
     let (cu,_) =
           if supernaive
              then compilation className
                               (reveal closedCoreExpr)
              else compilation className inlinedCore
     return $ prettyPrint cu

-- | Dependent Core expression to Java.
picore2java :: DumpOption -> Compilation2 -> ClassName -> Exp -> IO String
picore2java optDump compilation className closedCoreExpr = do
  let rewrittenCore = rewriteAndEval closedCoreExpr
  let core = runFreshM (NC.core2New rewrittenCore)
  when (optDump == SimpleCore) $ putStrLn (showExpr core)
  let cu = compilation className core
  return $ prettyPrint cu

type Compilation = String -> Core.Expr Int (OB.Var,ClosureF.Type Int) -> (J.CompilationUnit,ClosureF.Type Int)

type Compilation2 = String -> NC.Expr -> J.CompilationUnit

-- | Setting for various combination of optimization
-- Setting for naive
type NType = State Int

type NType2 = FreshMT (R.Reader Context)

ninst :: OB.Translate NType  -- instantiation; all coinstraints resolved
ninst = naive

ninstN :: NB.Translate NType2  -- instantiation; all coinstraints resolved
ninstN = naiveN

translateN
  :: String
  -> ClosureF.Expr Int (OB.Var,ClosureF.Type Int)
  -> NType (J.CompilationUnit,ClosureF.Type Int)
translateN = OB.createWrap (up ninst)

translateN2
  :: String
  -> NC.Expr
  -> NType2 J.CompilationUnit
translateN2 = NB.createWrap (up ninstN)

compileN :: Compilation
compileN name e = evalState (translateN name (ClosureF.fexp2cexp e)) 1

compileN2 name e = R.runReader (runFreshMT (translateN2 name e)) initialEnv

-- Setting for apply + naive
type AOptType = ReaderT Int (ReaderT OB.InitVars (State Int))

aoptinst :: ApplyOptTranslate AOptType  -- instantiation; all coinstraints resolved
aoptinst = applyopt

translateAO
  :: String
  -> ClosureF.Expr Int (OB.Var,ClosureF.Type Int)
  -> AOptType (J.CompilationUnit,ClosureF.Type Int)
translateAO = OB.createWrap (up aoptinst)

compileAO :: Compilation
compileAO name e = evalState (runReaderT (runReaderT (translateAO name (ClosureF.fexp2cexp e)) 0) []) 1

-- Setting for stack + naive
type StackNaiveType = ReaderT Bool (State Int)

stackNaiveinst :: TranslateStack StackNaiveType  -- instantiation; all coinstraints resolved
stackNaiveinst = stackNaive

translateSN
  :: String
  -> ClosureF.Expr Int (OB.Var,ClosureF.Type Int)
  -> StackNaiveType (J.CompilationUnit,ClosureF.Type Int)
translateSN = OB.createWrap (up stackNaiveinst)

compileSN :: Compilation
compileSN name e = evalState (runReaderT (translateSN name (ClosureF.fexp2cexp e)) True) 1

-- Setting for unbox + naive
-- unboxinst :: UnboxTranslate NType  -- instantiation; all coinstraints resolved
-- unboxinst = unboxopt

-- translateUnbox :: String -> Expr Int (Var, Type Int) -> NType (J.CompilationUnit, Type Int)
-- translateUnbox = createWrap (up unboxinst)

-- compileUnbox :: Compilation
-- compileUnbox name e = evalState (runReaderT (translateUnbox name (fexp2cexp e)) (0, True)) 1

-- Setting for apply + unbox + naive
-- aoptUnboxInst :: ApplyOptTranslate AOptType
-- aoptUnboxInst = applyUnbox

-- translateAU :: String -> Expr Int (Var, Type Int) -> AOptType (J.CompilationUnit, Type Int)
-- translateAU = createWrap (up aoptUnboxInst)

-- compileAoptUnbox :: Compilation
-- compileAoptUnbox name e = evalState (runReaderT (runReaderT (translateAU name (fexp2cexp e)) (0, True)) []) 1

-- Setting for stack + unbox + naive
-- stackUnboxInst :: TranslateStack NType
-- stackUnboxInst = stackUnbox

-- translateSU :: String -> Expr Int (Var, Type Int) -> NType (J.CompilationUnit, Type Int)
-- translateSU = createWrap (up stackUnboxInst)

-- compileSU :: Compilation
-- compileSU name e =  evalState (runReaderT (translateSU name (fexp2cexp e)) (0, True)) 1

type ApplyStackTranslate = ReaderT Int (ReaderT Bool (ReaderT OB.InitVars (State Int)))

-- Setting for apply + stack + naive
stackinst :: ApplyOptTranslate ApplyStackTranslate  -- instantiation; all coinstraints resolved
stackinst = stackApplyNew

translateS
  :: String
  -> ClosureF.Expr Int (OB.Var,ClosureF.Type Int)
  -> ApplyStackTranslate (J.CompilationUnit,ClosureF.Type Int)
translateS = OB.createWrap (up stackinst)

compileS :: Compilation
compileS name e = evalState (runReaderT (runReaderT (runReaderT (translateS name (ClosureF.fexp2cexp e)) 0) True) []) 1

-- Setting for apply + stack + unbox + naive
-- stackau :: ApplyOptTranslate AOptType
-- stackau = stackApplyUnbox

-- translateSAU :: String -> Expr Int (Var, Type Int) -> AOptType (J.CompilationUnit, Type Int)
-- translateSAU = createWrap (up stackau)

-- compileSAU :: Compilation
-- compileSAU name e = evalState (runReaderT (runReaderT (translateSAU name (fexp2cexp e)) (0, True)) []) 1


<|start_filename|>frontend/Examples.hs<|end_filename|>
{-# OPTIONS_GHC
    -fno-warn-missing-signatures
    -fno-warn-orphans
    -fno-warn-unused-imports #-}

module Examples where

import qualified Src as S
import Core
import Simplify
import PartialEvaluator
import Inliner
import Translations
import SymbolicEvaluator
import Z3Backend

import PrettyUtils
import OptiUtils

import Text.PrettyPrint.ANSI.Leijen

import Unsafe.Coerce
import qualified SystemFI as FI

import qualified Language.Java.Syntax as J (Op(..))

instance Show (Expr t e) where
  show = show . prettyExpr . unsafeCoerce

instance Show (Type t) where
  show = show . prettyType . unsafeCoerce

instance Show Value where
    show = show . pretty

instance Show ExecutionTree where
    show = show . pretty

-- let tailFact : Int -> Int -> Int
--   = \(acc : Int). \(n : Int). if n == 0 then acc else tailFact (acc * n) (n - 1)
-- in
-- tailFact 1 10
tailFact :: Expr t e
tailFact
  = fix (\tail_fact acc ->
      lam javaInt (\n ->
        If (var n `eq` zero)
           (var acc)
           (var tail_fact `App` (var acc `mult` var n) `App` (var n `sub` one))))
    javaInt (javaInt `Fun` javaInt)


testTail :: Expr t e
testTail = fix (\f n -> If (var n `eq` zero)
                           one
                           (var f `App` (var n `sub` one)))
               javaInt
               (javaInt `Fun` javaInt)

fact :: Expr t (Expr t e)
fact = fix (\f n -> If (var n `eq` zero)
                       one
                       (var n `mult` (var f `App` (var n `sub` one))))
           javaInt
           (javaInt `Fun` javaInt)

tailFactLike :: Expr t e
tailFactLike
  = fix (\tail_fact acc ->
      lam javaInt (\n ->
        If (var n `eq` zero)
           (var acc)
           (var tail_fact `App` (var acc `mult` one) `App` one)))
    javaInt (javaInt `Fun` javaInt)


plus2 :: Expr t e
plus2 = (App (lam (Fun javaInt (Fun javaInt javaInt))
                  (\e -> (App (App (var e) one) zero)))
             (lam javaInt (\e -> (lam javaInt (\f -> (var e) `mult` (var f))))))

-- let rec
--   even : Int -> Int = \(n : Int). if n == 0 then True  else odd  (n - 1)
--   odd  : Int -> Int = \(n : Int). if n == 0 then False else even (n - 1)
-- in
-- even 42
evenOdd :: Expr t e
evenOdd
  = LetRec
      ["even", "odd"]
      [(Fun javaInt javaBool), (Fun javaInt javaBool)]
      (\ids ->
         [ lam javaInt (\n -> If (var n `eq` zero) true  (App (var (ids !! 1)) (var n `sub` one)))
         , lam javaInt (\n -> If (var n `eq` zero) false (App (var (ids !! 0)) (var n `sub` one)))])
      (\ids ->
         App (var (ids !! 1)) magicNumber)


-- Int -> (Int -> Bool, Int -> Bool)
evenOddEncodedTy :: Type t
evenOddEncodedTy = javaInt `Fun` Product [javaInt `Fun` javaBool, javaInt `Fun` javaBool]

-- konstTy :: Type t
-- konstTy = Forall "konst" (\a -> Forall (\b -> Fun (tVar a) (Fun (tVar b) (tVar a))))

callByValue = lam javaInt (\x -> Seq [println (var x), intLit 0])
callByName  = lam (Fun Unit javaInt) (\x -> Seq [println (var x), intLit 0])
something   = Seq [println (Lit (S.String "called!")), intLit 1]
println x   = JMethod (S.Static "java.lang.System.out") "println" [x] undefined
intLit      = Lit . S.Int

-----------------------
-- peval tests
-----------------------
identity :: Expr t e
identity = lam javaInt (\x -> var x)
id_1 = App identity one

id_twice = lam javaInt (\x -> App identity (var x))
app_id_twice_1 = App id_twice one

--id_4times = lam javaInt (\x -> App id_twice

app_lam_if = App (lam javaInt (\x -> If ((var x) `eq` one)
                                 ((var x) `sub` one)
                                 (zero `sub` one)))
             (zero `sub` one)
app_lam_app = App (lam javaInt (\x -> App (lam javaInt (\y -> (var x) `sub` (var y))) zero))
              one

fix' = fix (\f n -> If (((one `sub` zero) `eq` zero))
                   one
                   (var n `mult` (var f `App` (var n `sub` one))))
      javaInt
      (javaInt `Fun` javaInt)
app_fix = App fix' (Lit (S.Int 10))

-- test App e1 e2, where e1 can be partially evaluated to a Lam
minus = lam javaInt (\x -> lam javaInt (\y -> var x `sub` var y))
minus_1 = App minus one
minus_1_0 = App minus_1 zero

if_lam = If (one `eq` one) (App minus one) (App minus zero)
app_if_lam = App if_lam one

-- complex test
complex_eq_zero = If (((App identity minus_1_0) `sub` one) `eq` zero)
                  zero
                  one


-- tests for seval
p1 = lam javaInt (\n -> If ((var n) `lt` ten) negOne one)

p2 = lam javaInt (\n -> If ((var n) `lt` five) negOne one)

prop_p1_p2 = lam javaInt (\n -> (App p1 (var n)) `eq` (App p2 (var n)))


if_bool = lam javaBool (\n -> If (var n `eq` true) negOne one)

inverse = lam javaBool (\_ -> If (true) false true)

intfun = lam (Fun javaInt javaInt) (\n -> If ((App (var n) one) `neq` (App (var n) one)) one negOne)

intfun2 = lam (Fun javaInt javaInt) (\n -> If (false `bAnd` ((App (var n) one) `neq` (App (var n) one))) one negOne)

multiple_if = lam (javaInt) (\n -> If ((var n) `eq` zero) (If ((App identity (var n)) `eq` one) one zero) negOne)

boolfun = lam (Fun javaBool javaBool) (\n -> If ((App (var n) true) `neq` (App (var n) true)) one negOne)

app_bool_fun = App boolfun inverse

-- interface to symbolic evaluator
se str = src2fi str >>= explore 20
seN n str = src2fi str >>= explore n

javaBool     = JClass "java.lang.Boolean"
zero         = Lit (S.Int 0)
one          = Lit (S.Int 1)
two          = Lit (S.Int 2)
five         = Lit (S.Int 5)
ten          = Lit (S.Int 10)
negOne       = Lit (S.Int (-1))
magicNumber  = Lit (S.Int 42)
true         = Lit (S.Bool True)
false        = Lit (S.Bool False)
x `eq` y     = PrimOp x (S.Compare J.Equal) y
x `neq` y    = PrimOp x (S.Compare J.NotEq) y
x `lt` y     = PrimOp x (S.Compare J.LThan) y
x `gt` y     = PrimOp x (S.Compare J.GThan) y
x `bAnd` y    = PrimOp x (S.Logic J.And) y
x `add` y    = PrimOp x (S.Arith J.Add) y
x `sub` y    = PrimOp x (S.Arith J.Sub) y
x `mult` y   = PrimOp x (S.Arith J.Mult) y


<|start_filename|>frontend/Loop.hs<|end_filename|>
{- |
Module      :  FileLoad
Description :  The main loop for the REPL
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  stable
Portability :  portable
-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}

module Loop where

import           Control.Concurrent (threadDelay)
import qualified Control.Exception as E
import           Control.Monad (liftM)
import           Control.Monad.Except (liftIO)
import           Data.List (stripPrefix, group, sort)
import qualified Data.Map as Map
import           System.CPUTime
import           System.Console.Haskeline
import           System.Directory


import           BackEnd
import qualified Core
import           Desugar (desugar)
import qualified Environment as Env
import           FileIO
import qualified History as Hist
import           ParseCMD
import           Parser
import           Simplify (simplify')
import           Src hiding (wrap)
import qualified SystemFI as FI
import           Text.PrettyPrint.ANSI.Leijen
import           TypeCheck

#ifdef Z3
-- #if MIN_VERSION_z3(0,3,2)
import           Z3Backend
#endif

loop :: Connection -> CompileOpt -> ValueContext -> Env.Env -> Hist.Hist -> Hist.Hist -> Int -> Bool -> Bool -> Bool -> Bool -> Int -> InputT IO ()
loop handle opt val_cxt env hist histOld index flagC flagH flagT flagS num = do
        let max = length hist
        case flagH of
          True  -> case (index == max)  of
            True  -> do
              let hist = histOld
              loop handle opt val_cxt env hist histOld 0 flagC False flagT flagS num
            False -> do
              let newHist = if (hist == histOld) then reverse hist else hist
              let cmd = newHist !! index
              liftIO (threadDelay $ 1000000)
              outputStrLn ""
              outputStrLn ("Replaying: " ++ cmd)
              runCMD handle opt val_cxt env hist histOld (index+1) flagC True flagT flagS num cmd
          False -> do
            msg <- getInputLine "f2ji> "
            case msg of
              Nothing    -> return ()
              Just ""    -> loop handle opt val_cxt env hist histOld 0
                                 flagC False flagT flagS num
              Just input -> do
                case input of
                  ":replay" -> runCMD handle opt val_cxt env hist histOld 0
                                      flagC False flagT flagS num input
                  ":replay default" -> runCMD handle opt val_cxt env hist histOld 0
                                              flagC False flagT flagS num input
                  other     -> do
                    let histNew = Hist.insert hist input
                    let histOld = histNew
                    runCMD handle opt val_cxt env histNew histOld 0
                           flagC False flagT flagS num input

runCMD :: Connection -> CompileOpt -> ValueContext -> Env.Env -> Hist.Hist -> Hist.Hist -> Int -> Bool -> Bool -> Bool -> Bool -> Int -> String -> InputT IO ()
runCMD handle opt val_ctx env hist histOld index flagC flagH flagT flagS num msg = do
        case (stripPrefix ":" msg) of
          Just input ->
                case parseMsg msg of
                  Left err   ->  outputStrLn "Parse error"
                  Right line -> processCMD handle opt val_ctx env hist histOld index
                                           flagC flagH flagT flagS num line
          Nothing   -> do
                case parseExpr msg of
                  ParseOk readSrc -> do
                    result <- liftIO (checkExprWithEnv val_ctx readSrc)
                    case result of
                      Left typeErr        -> do
                        outputStrLn (show typeErr)
                        loop handle opt val_ctx env hist histOld index
                             flagC flagH flagT flagS num
                      Right (t, tchecked) -> do
                        let filename = "main_" ++ (show num) ++ ".sf"
                        let bind = Env.reverseEnv env
                        let msgEnv = (Env.createBindEnv bind) ++ msg
                        liftIO (writeFile filename msgEnv)
                        liftIO (wrapFlag handle opt flagC flagT flagS filename)
                        exist <- liftIO (doesFileExist filename)
                        if exist
                          then do liftIO (removeFile filename)
                                  loop handle opt val_ctx env hist histOld index
                                       flagC flagH flagT flagS (num+1)
                          else loop handle opt val_ctx env hist histOld index
                                    flagC flagH flagT flagS (num+1)
                  ParseError msg -> do
                    outputStrLn msg
                    loop handle opt val_ctx env hist histOld index
                         flagC flagH flagT flagS num

processCMD :: Connection -> CompileOpt -> ValueContext -> Env.Env -> Hist.Hist -> Hist.Hist -> Int -> Bool -> Bool -> Bool -> Bool -> Int -> [String] -> InputT IO ()
processCMD handle opt val_ctx env hist histOld index flagC flagH flagT flagS num (x:xs) = do
        case x of
          ":help" -> do
                liftIO printHelp
                loop handle opt val_ctx env hist histOld index
                     flagC flagH flagT flagS num
          ":run" -> do
                case getCMD xs of
                  Just filename -> liftIO (wrapFlag handle opt flagC flagT flagS filename)
                  Nothing       ->  outputStrLn "Invalid input"
                loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
          -- ":link" -> do
          --       let (list1,modList) = splitAt 2 xs
          --       let file = head list1
          --       content <- liftIO (Link.linkModule modList)
          --       outputStrLn "Linking..."
          --       liftIO (Link.link file content)
          --       let newFile = (dropExtension file) ++ "c.sf"
          --       outputStrLn (newFile ++ " generated!")
          --       loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num

#ifdef Z3
          ":se" -> do
                case getCMD xs of
                  Just filename -> do expr <- liftIO (src2fi filename)
                                      case getCMD (tail xs) of
                                        Just n -> liftIO $ explore (read n) expr
                                        Nothing -> liftIO $ explore 20 expr
                  Nothing       -> outputStrLn "Invalid input"
                loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
          ":sc" -> do
                case getCMD xs of
                  Just filename -> do expr <- liftIO (src2fi filename)
                                      case getCMD (tail xs) of
                                        Just n -> liftIO $ counter (read n) expr
                                        Nothing -> liftIO $ counter 20 expr
                  Nothing       -> outputStrLn "Invalid input"
                loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
#endif
          ":expr" -> do
                case getCMD xs of
                  Just filename -> do
                    expr <- liftIO (src2core filename)
                    outputStrLn (show (Core.prettyExpr expr))
                  Nothing       -> outputStrLn "Invalid input"
                loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
          ":set" -> case getCMD xs of
                Just "method" -> do
                  let (y:ys)= xs
                  let ms = parseMethod ys
                  result <- liftIO (E.try (getOpt ms))
                  case result of
                    Left (_ :: E.SomeException) -> do
                      outputStrLn "Invalid method"
                      loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                    Right optNew                -> do
                      loop handle optNew val_ctx env hist histOld index
                           flagC flagH flagT flagS num
                Just "simplify" -> do
                   let (y:ys) = xs
                   case getCMD ys of
                     Just "on"  -> loop handle opt val_ctx env hist histOld index
                                   True flagH flagT flagS num
                     Just "off" -> loop handle opt val_ctx env hist histOld index
                                   False flagH flagT flagS num
                     _          -> do
                       outputStrLn "Invalid input"
                       loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                _             -> do
                  outputStrLn "Invalid input"
                  loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
          ":quit" -> return ()
          ":let"  -> do
                if (length xs) < 3
                  then do
                    outputStrLn "Parse error: no space around \"=\"/Too few input"
                    loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                  else if (xs !! 1) /= "="
                    then do
                      outputStrLn "Parse error: no space around \"=\""
                      loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                    else do
                      let (var, exp) = Env.createPair xs
                      case parseExpr exp of
                        ParseOk readSrc -> do
                          result <- liftIO (checkExprWithEnv val_ctx readSrc)
                          case result of
                            Left  typeErr     -> do
                              outputStrLn (show typeErr)
                              loop handle opt val_ctx env hist histOld index
                                   flagC flagH flagT flagS num
                            Right (t, tchecked) -> do
                              let val_ctx_new = Map.insert var t val_ctx
                              let envNew = Env.insert (var, exp) env
                              loop handle opt val_ctx_new envNew hist histOld index
                                   flagC flagH flagT flagS num
                        ParseError msg -> do
                          outputStrLn msg
                          loop handle opt val_ctx env hist histOld index
                               flagC flagH flagT flagS num
          ":type" -> do
                case getCMD xs of
                  Just var -> case Map.lookup var val_ctx of
                    Just t  -> outputStrLn (show $ pretty t)
                    Nothing -> outputStrLn "variable not found"
                  Nothing  ->  outputStrLn "Too few input"
                loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
          ":show" -> case getCMD xs of
                Just "time"   -> do
                  let (y:ys) = xs
                  case getCMD ys of
                    Just "on"  -> loop handle opt val_ctx env hist histOld index
                                       flagC flagH True flagS num
                    Just "off" -> loop handle opt val_ctx env hist histOld index
                                       flagC flagH False flagS num
                    _        -> do
                      outputStrLn "Invalid option for :set time"
                      loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                Just "file"   -> do
                  let (y:ys) = xs
                  case getCMD ys of
                    Just "on"  -> loop handle opt val_ctx env hist histOld index
                                  flagC flagH flagT True num
                    Just "off" -> loop handle opt val_ctx env hist histOld index
                                  flagC flagH flagT False num
                    _          -> do
                      outputStrLn "Invalid option for :show file"
                      loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                Just "env"    -> do
                  outputStrLn ("[" ++ Env.showPrettyEnv env ++ "]")
                  loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                Just "method" -> do
                  let (num, compile, method) = opt
                  outputStrLn ("Currently using: " ++ show method)
                  outputStrLn "----------------------------"
                  outputStrLn "Avaible compilation options:"
                  outputStrLn "(Can also be the combination of the first four methods)"
                  outputStrLn "----------------------------"
                  outputStrLn "naive"
                  outputStrLn "apply"
                  outputStrLn "unbox"
                  outputStrLn "stack"
                  outputStrLn "benchs"
                  outputStrLn "benchna"
                  outputStrLn "benchsa"
                  outputStrLn "benchsai1"
                  outputStrLn "benchsai2"
                  outputStrLn "---------------------------"
                  outputStrLn "Default: naive"
                  loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                Just input -> do
                  exist <- liftIO (doesFileExist input)
                  case exist of
                    True  -> do
                        content <- liftIO (readFile input)
                        outputStrLn content
                    False -> outputStrLn "Invalid input"
                  loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
                Nothing    -> do
                  outputStrLn "Too few input"
                  loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
          ":clear"  -> loop handle opt Map.empty Env.empty hist histOld index
                            flagC flagH flagT flagS num
          ":replay" -> case getCMD xs of
              Nothing -> do
                let envNew = Env.empty
                --outputStrLn (show hist)
                loop handle opt val_ctx envNew hist histOld 0 flagC True flagT flagS num
              Just "default" -> do
                cmd <- liftIO (readFile "default.txt")
                let histOld = hist
                let hist = lines cmd
                --outputStrLn (show hist)
                loop handle opt val_ctx env hist histOld 0 flagC True flagT flagS num
              Just input -> outputStrLn "Invalid option for :replay!"
          input   -> do
            outputStrLn $ "Command not recognized: " ++ input
            loop handle opt val_ctx env hist histOld index flagC flagH flagT flagS num
processCMD _ _ _ _ _ _ _ _ _ _ _ _ [] = outputStrLn "Parse error!"

getCMD :: [String] -> Maybe String
getCMD xs = case xs of
                []      -> Nothing
                (x:xs)  -> Just x

parseMethod :: [String] -> [String]
parseMethod xs = (map head . Data.List.group . sort) xs;

-- if the return type is CompileOpt, then return to E.try (return (getOpt method))
-- will not evaluate argument inside return (lazy), thus can't catch error
getOpt :: [String] -> IO CompileOpt
getOpt ms = case ms of
        ["naive"]               -> return (0, compileN, [Naive])
        ["apply"]               -> return (0, compileAO, [Apply, Naive])
        -- ["apply", "unbox"]      -> return (0, compileAoptUnbox, [Apply, Naive, Unbox])
        ["apply", "stack"]      -> return (0, compileS, [Apply, Naive, Stack])
        -- ["apply", "stack", "unbox"]
        --                         -> return (0, compileSAU, [Apply, Naive, Stack, Unbox])
        -- ["stackau1"]            -> return (1, compileSAU, [Naive, StackAU1])
        -- ["stackau2"]            -> return (2, compileSAU, [Naive, StackAU2])
        ["stack"]               -> return (0, compileSN, [Naive, Stack])
        -- ["stack", "unbox"]      -> return (0, compileSU, [Naive, Stack, Unbox])
        -- ["unbox"]               -> return (0, compileUnbox, [Naive, Unbox])
        --["benchs"]            -> return (0, (compileBS False), [BenchS])
        --["benchna"]           -> return (0, (compileBN True), [BenchNA])
        --["benchSA"]           -> return (0, (compileBS True), [BenchSA])
        --["benchSAI1"]         -> return (1, (compileBS True), [BenchSAI1])
        --["benchSAI2"]                 -> return (2, (compileBS True), [BenchSAI2])
        _                       -> error "invalid method"

wrapFlag :: Connection -> CompileOpt -> Bool -> Bool -> Bool -> String -> IO ()
wrapFlag handle opt flagC flagT flagS filename = case flagT of
        True  -> --timeIt (wrap handle opt flagS filename)
          do start <- getCPUTime
             error <- wrap handle receiveMsg opt flagC flagS filename
             end <- getCPUTime
             putStrLn ("CPU time: " ++ (show ((end - start) `div` 1000)) ++ "ns")
        False -> do error <- wrap handle receiveMsg opt flagC flagS filename
                    return ()

{-checkType :: ValueContext -> String -> IO (Either TypeError (Type, CheckedExpr))
checkType val_ctx s =
  do let parsed = parseExpr s
     checkExprWithEnv val_ctx parsed
       -}

printHelp :: IO ()
printHelp = do
        putStrLn ""
        putStrLn "Welcome to f2ji!"
        putStrLn "-----------------------------------------"
        putStrLn "[COMMANDS] [SOURCE FILE/FLAG]"
        putStrLn "Commands:"
        putStrLn ":help                 Display help manual"
        putStrLn ":run <sourceFile>     Compile and run sourceFile"
        -- putStrLn ":link <sourceFile> -m <module1> <module2> ..."
        -- putStrLn "                      Link sourceFile with modules"
        putStrLn ":expr <sourceFile>    Show core expression of the file"
#ifdef Z3
        putStrLn ":se <sourceFile> n    Symbolically evaluate the file"
        putStrLn ":sc <sourceFile> n    Symbolically check the file. Report counter-example if the property is not true."
#endif
        putStrLn ":let var = expr       Bind expr to var"
        putStrLn ":type var             Show the type of var"
        putStrLn ":replay               Replay all previous user commands"
        putStrLn ":replay default       Replay commands from default.txt"
        putStrLn ":clear                Clear environment"
        putStrLn ":quit                 Quit f2ji"
        putStrLn ""
        putStrLn "--- Commands for settings ---"
        putStrLn ":set method opt       Set compilation options"
        putStrLn ":set simplify on/off  Turn on/off the simplifier"
        putStrLn ""
        putStrLn "--- Commands for displaying information ---"
        putStrLn ":show time on/off     Show/Hide execution time"
        putStrLn ":show file on/off     Show/Hide source file and .java file contents"
        putStrLn ":show <sourcefile>    Show file content"
        putStrLn ":show env             Show current bindings"
        putStrLn ":show method          Show available compilation options"
        putStrLn "-----------------------------------------"

src2core :: String -> IO (Core.Expr t e)
src2core fname = liftM simplify' $ src2fi fname

-- fCore :: (Expr t e -> b) -> String -> IO b
-- fCore f fname = liftM f $ src2core fname

src2fi :: String -> IO (FI.Expr t e)
src2fi fname = do
     path <- getCurrentDirectory
     string <- readFile (path ++ "/" ++ fname)
     case parseExpr string of
       ParseOk expr -> do
         result <- checkExpr expr
         case result of
           Left typeError -> error $ show typeError
           Right (_, tcheckedSrc) ->
                 return . desugar $ tcheckedSrc
       ParseError msg -> error msg


<|start_filename|>frontend/ParseCMD.hs<|end_filename|>
{- |
Module      :  ParseCMD
Description :  Parser for the REPL
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  stable
Portability :  portable

-}

module ParseCMD where

import Text.ParserCombinators.Parsec

line = sepBy cell (char ' ')
cell = many (noneOf " ")

parseMsg :: String -> Either ParseError [String]
parseMsg input = parse line "(unknown)" input




<|start_filename|>repl/Environment.hs<|end_filename|>
{- |
Module      :  Environment
Description :  REPL environment
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  stable
Portability :  portable
-}

module Environment where

import Data.List.Split

import Parser
import Src
import Text.PrettyPrint.ANSI.Leijen

type Env = [(String, Exp)]
type Exp = (String, Src.ParsedExpr)

empty :: Env
empty = []

insert :: (String, String) -> Env -> Env
insert (var, exp) env =
  case Parser.parseExpr exp of
    ParseOk expr     -> (var, (exp, expr)) : env
    ParseError error -> env

createExp :: [String] -> String
createExp [] = ""
createExp (x:xs) = x ++ " " ++ createExp xs

-- y is "="
-- Sample input: ["x", "=", "y" , "+", "2"]
-- Sample output: splitOn ["="] xs ~> [["x"], ["y", "+", "2"]]
-- Sample output: ("x", "y+2")
createPair :: [String] -> (String, String)
createPair xs = (var, exp) where
        var = ((splitOn ["="] xs) !! 0) !! 0
        exp = createExp ((splitOn ["="] xs) !! 1)

reverseEnv :: Env -> Env
reverseEnv = reverse

createBindEnv :: Env -> String
createBindEnv [] = ""
createBindEnv ((var,(str,expr)) : xs) = "let " ++ var ++ " = " ++ str
                                        ++ " in " ++ createBindEnv xs
searchEnv :: String -> Env -> Bool
searchEnv var env = case lookup var env of
                        Nothing  -> False
                        Just exp -> True

showPrettyEnv :: Env -> String
showPrettyEnv [] = ""
showPrettyEnv ((var, (_, expr)) : xs) = "(" ++ show var ++ ", "
                                              ++ show (pretty expr)
                                              ++ "); " ++ showPrettyEnv xs


<|start_filename|>examples/case_studies/HeapSort.hs<|end_filename|>
{-# LANGUAGE TemplateHaskell #-}

module HeapSort where


{-
1. Try "runTests" in the terminal to test all the properties
2. Try "multiTestNv" to test the naive version of "prop_buggyRemoveMaxNv" 10 times with time
   showed below.
3. Try "multiTestCl" to test the clever version of "prop_buggyRemoveMaxCl" 10 times with time
   showed below.
-}

import Test.QuickCheck
import Test.QuickCheck.All
import qualified Data.Set as Set
import MonadLib
import System.CPUTime
import System.Timeout

--type Heap
data Heap = Leaf | Node { rk :: Int,
                          value :: Int,
                          left :: Heap,
                          right :: Heap
                        } deriving (Show, Eq)

-----------------test data generator and shrink for Heap-------------------------
instance Arbitrary Heap where
  arbitrary = sized arbHeap
  shrink = shrinkHeap

arbHeap 0 = return Leaf
arbHeap n =frequency
         [ (1, return Leaf)
         , (4, liftM4 Node (choose (0,65536))
                           (choose (-65536, 65536))
                           (arbHeap (n `div` 2))
                           (arbHeap (n `div` 2))) ]

shrinkHeap :: Heap -> [Heap]
shrinkHeap (Node rk v l r) = [Leaf] ++
                             [(Node rk' v l r) | rk' <- shrink rk] ++
                             [(Node rk v' l r) | v'  <- shrink v ] ++
                             [(Node rk v l' r) | l' <- shrinkHeap l] ++
                             [(Node rk v l r') | r' <- shrinkHeap r]
shrinkHeap _               = []

------------------------------------------------------------------------


--function "rightHeight"
rightHeight :: Heap -> Int
rightHeight Leaf = 0
rightHeight (Node _ _ _ r) = (rightHeight r) + 1


--function "rank"
rank :: Heap -> Int
rank Leaf = 0
rank (Node rk _ _ _) = rk


--function "rootVal"
rootVal :: Heap -> Int
rootVal h@(Node _ v _ _)
  | (h /= Leaf) = v
  | otherwise = error "the input heap is a Leaf"


--function "hasLeftistProperty"
hasLeftistProperty :: Heap -> Bool
hasLeftistProperty Leaf = True
hasLeftistProperty h@(Node _ v l r) = (hasLeftistProperty l)
                                 && (hasLeftistProperty r)
                                 && (rightHeight l) >= (rightHeight r)
                                 && (rank h) == (rightHeight h)
                                 && ((l == Leaf) || v >= (rootVal l))
                                 && ((r == Leaf) || v >= (rootVal r))



--function "heapSize"
heapSize :: Heap -> Int
heapSize Leaf = 0
heapSize (Node _ v l r) = (heapSize l) + 1 + (heapSize r)
----test for heapSize
prop_heapSize :: Heap -> Bool
prop_heapSize h = (heapSize h) >= 0


--function "heapContents"
heapContents :: Heap -> Set.Set Int
heapContents Leaf = Set.empty
heapContents (Node _ v l r) = Set.unions [(Set.singleton v),
                                      (heapContents l),
                                      (heapContents r)]


--function "merge"
merge :: Heap -> Heap -> Heap
merge Leaf h2 = h2
merge h1 Leaf = h1
merge h1@(Node _ v1 l1 r1) h2@(Node _ v2 l2 r2) = if v1 > v2
                                      then makeT v1 l1 (merge r1 h2)
                                      else makeT v2 l2 (merge h1 r2)
----test for merge
prop_merge :: Property
prop_merge =
  forAll hasLeftistHeap $ \h1 ->
   forAll hasLeftistHeap $ \h2 ->
        collect (heapSize h1) $
        collect (heapSize h2) $
     (if (merge h1 h2) == Leaf then (h1 == Leaf) && (h2 == Leaf)
                              else (((h1 /= Leaf) && ((rootVal h1) == (value (merge h1 h2)))) || ((h2 /= Leaf) && ((rootVal h2) == (value (merge h1 h2))))))
 && (hasLeftistProperty (merge h1 h2))
 && ((heapSize h1) + (heapSize h2) == heapSize (merge h1 h2))
-- && (Set.union (heapContents h1) (heapContents h2) == heapContents (merge h1 h2))



prop_hasLeftistHeap :: Heap -> Property
prop_hasLeftistHeap h = collect (heapSize h) $ hasLeftistProperty $ mkrV $ mkLP h
----------------------------------------------------------------------
---try to make a generator to provide test data with hasLeftistProperty

--help-function to trun a heap into a heap satisfied hasLeftistProperty
mkLP :: Heap -> Heap
mkLP Leaf = Leaf
mkLP h@(Node rk v Leaf Leaf) = (Node 1 0 Leaf Leaf)
mkLP h@(Node rk v l Leaf) = (Node 1 (rootVal l) (mkLP l) Leaf)
mkLP h@(Node rk v Leaf r) = (Node 1 (rootVal r) (mkLP r) Leaf)
mkLP h@(Node rk v l r) =
      if rl >= rr
         then (Node (rr + 1) v (mkLP l) (mkLP r))
         else (Node (rl + 1) v (mkLP r) (mkLP l))
          where rl = rightHeight (mkLP l)
                rr = rightHeight (mkLP r)
--help-function to make root rooVal larger than its subheap rootVal
mkrV :: Heap -> Heap
mkrV Leaf = Leaf
mkrV (Node rk v Leaf Leaf) = (Node rk v Leaf Leaf)
mkrV (Node rk v l Leaf) = if v >= (rootVal (mkrV l))
                       then (Node rk v (mkrV l) Leaf)
                       else (Node rk (rootVal (mkrV l)) (mkrV l) Leaf)
mkrV (Node rk v Leaf r) = if v >= (rootVal (mkrV r))
                       then (Node rk v Leaf (mkrV r))
                       else (Node rk (rootVal (mkrV r)) Leaf (mkrV r))
mkrV (Node rk v l r) = if v >= ma then (Node rk v (mkrV l) (mkrV r))
                                  else (Node rk ma (mkrV l) (mkrV r))
                  where ma = max (rootVal (mkrV l)) (rootVal (mkrV r))

prop_mkrV :: Heap -> Bool
prop_mkrV Leaf = True
prop_mkrV h@(Node rk v l r) = ((ml == Leaf) || mv >= (rootVal ml))
                           && ((mr == Leaf) || mv >= (rootVal mr))
           where (Node mrk mv ml mr) = mkrV h


----generator for test data which satisfy hasLeftistProperty
hasLeftistHeap :: Gen Heap
hasLeftistHeap = mkrV `fmap` (mkLP `fmap` arbitrary)

----------------------------------------------------------------------


--function "makeT"
makeT :: Int -> Heap -> Heap -> Heap
makeT v l r = if (rank l) >= (rank r) then (Node ((rank r) + 1) v l r)
                                      else (Node ((rank l) + 1) v r l)


--function "insert"
insert :: Int -> Heap -> Heap
insert e h
  | hasLeftistProperty h = merge (Node 1 e Leaf Leaf) h
  | otherwise = error "the input heap does not have leftist property"

----test for insert
prop_insert :: Int -> Heap -> Property
prop_insert e h = hasLeftistProperty h ==>
              heapSize res == (heapSize h) + 1
           && heapContents res == Set.union (Set.singleton e)
                                            (heapContents h)
                where res = insert e h



--function "findMax"
findMax :: Heap -> Int
findMax h
   | hasLeftistProperty h && h /= Leaf =
    rootVal h
   | otherwise = error "the Input does not have leftist property or empty"


--function "removeMax"
removeMax :: Heap -> Heap
removeMax h = case h of (Node _ _ l r) -> merge l r
                        Leaf           -> h

----test for removeMax
prop_removeMax :: Heap -> Property
prop_removeMax h =  hasLeftistProperty h ==>
     -- forAll hasLeftistHeap $ \ h ->
      collect (heapSize h) $
      hasLeftistProperty (removeMax h) &&
    --  (h == Leaf || heapContents h ==
    --   (Set.union (heapContents (removeMax h)) (Set.singleton (findMax h)))) &&
      ((removeMax h) == Leaf || ((findMax (removeMax h)) < (findMax h)))


prop_buggyRemoveMaxNv :: Heap -> Property
prop_buggyRemoveMaxNv h =  hasLeftistProperty h ==>
    --  collect (heapSize h) $
      hasLeftistProperty (removeMax h) &&
      ((removeMax h) == Leaf || ((findMax (removeMax h)) < (findMax h)))


prop_buggyRemoveMaxCl :: Property
prop_buggyRemoveMaxCl =
     forAll hasLeftistHeap $ \ h ->
    --  collect (heapSize h) $
      hasLeftistProperty (removeMax h) &&
      ((removeMax h) == Leaf || ((findMax (removeMax h)) < (findMax h)))



--function "sortedDescending"
sortedDescending :: [Int] -> Bool
sortedDescending [] = True
sortedDescending [x] = True
sortedDescending (x:t@(y:_)) = (x >=y) && sortedDescending t


--function "removeElements"
removeElements :: Heap -> [Int]
removeElements h
   | hasLeftistProperty h = case h of Leaf -> []
                                      _ -> (:) (findMax h) (removeElements (removeMax h))

----test for removeElements
prop_removeElements :: Property
prop_removeElements =  -- hasLeftistProperty h ==>
           forAll hasLeftistHeap $ \ h ->
            collect (heapSize h) $
            sortedDescending (removeElements h)
         && heapSize h == length (removeElements h)
         && heapContents h == Set.fromList (removeElements h)



--function "buildHeap"
buildHeap :: [Int] -> Heap
buildHeap [] = Leaf
buildHeap (x:xs) = insert x (buildHeap xs)

----test for buildHeap
prop_buildHeap :: [Int] -> Bool
prop_buildHeap l = hasLeftistProperty res &&
                   heapContents res == Set.fromList l &&
                   heapSize res == length l
                    where res = buildHeap l


--function "heapSort"
heapSort :: [Int] -> [Int]
heapSort l = removeElements (buildHeap l)

----test for heapSort
prop_heapSort :: [Int] -> Bool
prop_heapSort l = sortedDescending res &&
                  length res == length l &&
                  Set.fromList res == Set.fromList l
                    where res = heapSort l



------------------------------------timer---------------------------------------
timeIt :: (Fractional c) => (a -> IO b) -> a -> IO c
timeIt action arg = do
       startTime <- getCPUTime
       action arg
       finishTime <- getCPUTime
       return $ fromIntegral (finishTime - startTime)  / 1000000000

oneTestNv = timeout 5000000 $ timeIt quickCheck prop_buggyRemoveMaxNv >>= print
oneTestCl = timeout 5000000 $ timeIt quickCheck prop_buggyRemoveMaxCl >>= print

multiTestNv = do
            startTime <- getCPUTime
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000

multiTestCl = do
            startTime <- getCPUTime
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000
---------------------------------------------------------------------------


------for-quickCheck-test------
return []
runTests = $quickCheckAll
-------------------------------











<|start_filename|>backend/OptiUtils.hs<|end_filename|>
{-# LANGUAGE RankNTypes #-}
-- | Some utilities for optimization purpose

module OptiUtils where

import           Data.List (foldl')
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromJust)

import           Core
import qualified Src



joinExpr :: Expr t (Expr t e) -> Expr t e
joinExpr (Var _ x) = x
joinExpr (Lam n t1 e1) = Lam n t1 (joinExpr . e1 . Var n )
joinExpr (App e1 e2) = App (joinExpr e1) (joinExpr e2)
joinExpr (BLam n t1) = BLam n (joinExpr . t1)
joinExpr (TApp e t) = TApp (joinExpr e) t
joinExpr (Lit s) = Lit s
joinExpr (If e1 e2 e3) = If (joinExpr e1) (joinExpr e2) (joinExpr e3)
joinExpr (PrimOp e1 o e2) = PrimOp (joinExpr e1) o (joinExpr e2)
joinExpr (Tuple es) = Tuple (map joinExpr es)
joinExpr (Error ty str)         = Error ty (joinExpr str)
joinExpr (Data recflag databinds e) = Data recflag databinds (joinExpr e)
joinExpr (ConstrOut ctr es) = ConstrOut ctr (map joinExpr es)
joinExpr (Case e alts) = Case (joinExpr e) (map joinAlt alts)
  where joinAlt (ConstrAlt ctr e1) = ConstrAlt ctr (joinExpr e1)
        joinAlt (Default e1) = Default (joinExpr e1)
joinExpr (Proj i e) = Proj i (joinExpr e)
joinExpr (Fix n1 n2 f t1 t2) = Fix n1 n2 (\e1 e2 -> joinExpr (f (Var n1 e1) (Var n2 e2))) t1 t2
joinExpr (Let n bind body) = Let n (joinExpr bind) (joinExpr . body . Var n)
joinExpr (LetRec n s b1 b2) =
  LetRec n s
         (map joinExpr . b1 . zipWith Var n)
         (joinExpr . b2 . zipWith Var n)
joinExpr (JNew name es) = JNew name (map joinExpr es)
joinExpr (JMethod jc m es cn) =
  JMethod (fmap joinExpr jc) m (map joinExpr es) cn
joinExpr (JField jc fn cn) = JField (fmap joinExpr jc) fn cn
joinExpr (Seq es) = Seq (map joinExpr es)
joinExpr (Module pname defs) = Module pname (joinDefs defs)

joinDefs :: Definition t (Expr t e) -> Definition t e
joinDefs Null = Null
joinDefs (Def n t expr def) = Def n t (joinExpr expr) (joinDefs . def . Var n)
joinDefs (DefRec names types exprs def) =
  DefRec names types (map joinExpr . exprs . zipWith Var names) (joinDefs . def . zipWith Var names)

mapExpr :: (Expr t e -> Expr t e) -> Expr t e -> Expr t e
mapExpr f e =
    case e of
      Var _ _ -> e
      Lit _ -> e
      Lam n t g -> Lam n t (\x -> f . g $ x)
      Fix n1 n2 g t1 t -> Fix n1 n2 (\e1 e2 -> f $ g e1 e2) t1 t
      Let n bind body -> Let n (f bind) (\x -> f . body $ x)
      LetRec names sigs binds body ->
          LetRec names sigs
                 (map f . binds)
                 (f . body)
      BLam n g -> BLam n (\x -> f . g $ x)
      App e1 e2 -> App (f e1) (f e2)
      TApp e' t -> TApp (f e') t
      If e1 e2 e3 -> If (f e1) (f e2) (f e3)
      PrimOp e1 op e2 -> PrimOp (f e1) op (f e2)
      Tuple es -> Tuple $ map f es
      Proj i e' -> Proj i (f e')
      Module pname defs -> Module pname (mapDefs defs)
      JNew cname es -> JNew cname (map f es)
      JMethod cnameOrE mname es cname -> JMethod (fmap f cnameOrE) mname (map f es) cname
      JField cnameOrE fname cname -> JField (fmap f cnameOrE) fname cname
      Error ty str -> Error ty (f str)
      Data recflag databinds e -> Data recflag databinds (f e)
      ConstrOut ctr es -> ConstrOut ctr (map f es)
      Case e' alts -> Case (f e') (map mapAlt alts)
         where mapAlt (ConstrAlt ctr e1) = ConstrAlt ctr (f e1)
               mapAlt (Default e1) = Default (f e1)
      Seq es -> Seq $ map f es
  where mapDefs (Def n t expr def) = Def n t (mapExpr f expr) (mapDefs . def)
        mapDefs (DefRec names types exprs def) = DefRec names types (map f . exprs) (mapDefs . def)
        mapDefs Null = Null


rewriteExpr :: (Int -> Map.Map Int e -> Expr t Int -> Expr t e) -> Int -> Map.Map Int e -> Expr t Int -> Expr t e
rewriteExpr f num env expr =
  case expr of
   Var n v -> Var n (fromJust $ Map.lookup v env)
   Lit n ->  Lit n
   Lam n t f' -> Lam n t (\e -> f (num + 1) (Map.insert num e env) (f' num))
   Fix n1 n2 f' t1 t2 -> Fix n1 n2 (\a b -> f (num + 2) (Map.insert (num + 1) b (Map.insert num a env)) (f' num (num + 1))) t1 t2
   Let n e f' -> Let n (f num env e) (\b -> f (num + 1) (Map.insert num b env) (f' num))
   LetRec n t b f' ->
     let len = length n
         range = [num .. num + len - 1]
     in LetRec n t (\bs -> let bs' = b range
                           in map (f (num + len) (foldl' multInsert env (zip range bs))) bs')
                   (\es -> let es' = f' range
                           in f (num + len) (foldl' multInsert env (zip range es)) es')
   BLam n f' -> BLam n (f num env . f')
   App e1 e2 -> App (f num env e1) (f num env e2)
   TApp e t -> TApp (f num env e) t
   If e1 e2 e3 -> If (f num env e1) (f num env e2) (f num env e3)
   PrimOp e1 op e2 -> PrimOp (f num env e1) op (f num env e2)
   Tuple es -> Tuple (map (f num env) es)
   Proj n e -> Proj n (f num env e)
   Module pname defs -> Module pname (rewriteDefs num env defs)
   JNew n es -> JNew n (map (f num env) es)
   JMethod e b es d -> JMethod (fmap (f num env) e) b (map (f num env) es) d
   JField e a b -> JField (fmap (f num env) e) a b
   Error ty str -> Error ty (f num env str)
   Seq es -> Seq (map (f num env) es)
   Data recflag databinds e -> Data recflag databinds (f num env e)
   ConstrOut c es -> ConstrOut c (map (f num env) es)
   Case e alts -> Case (f num env e) (map rewriteAlt alts)
 where
   rewriteAlt (ConstrAlt ctr e) = ConstrAlt ctr (f num env e)
   rewriteAlt (Default e)       = Default (f num env e)

   rewriteDefs _ _  Null = Null
   rewriteDefs num env (Def n t expr def) = Def n t (rewriteExpr f num env expr)
                                                    (\e -> rewriteDefs (num + 1)
                                                    (Map.insert num e env)
                                                    (def num))
   rewriteDefs num env (DefRec names types exprs def) =
     let len = length names
         range = [num .. num + len - 1]
     in DefRec names types (\bs -> let bs' = exprs range
                                   in map (f (num + len) (foldl' multInsert env (zip range bs))) bs')
                           (\es -> let es' = def range
                                   in rewriteDefs (num + len) (foldl' multInsert env (zip range es)) es')

newtype Exp = Hide {reveal :: forall t e. Expr t e}

instance Eq Exp where
  p1 == p2 = peq 0 (reveal p1) (reveal p2)

-- TODO: equality inside module?
peq :: Int -> Expr Int Int -> Expr Int Int -> Bool
peq _ (Var _ a) (Var _ b) = a == b
peq _ (Lit a) (Lit b) = a == b
peq n (Lam _ _ f1) (Lam _ _ f2) = peq (n + 1) (f1 n) (f2 n)
peq n (Fix _ _ f1 _ _) (Fix _ _ f2 _ _) = peq (n + 2) (f1 n (n + 1)) (f2 n (n + 1))
peq n (Let _ x f1) (Let _ y f2) = peq n x y && peq (n + 1) (f1 n) (f2 n)
peq n (LetRec _ _ f1 g1) (LetRec _ _ f2 g2) =
  let bind1 = f1 [n ..]
      len1 = length bind1
      bind2 = f2 [n ..]
      len2 = length bind2
      expr1 = g1 [n ..]
      expr2 = g2 [n ..]
  in len1 == len2 && peq (n + len1) expr1 expr2 && and (zipWith (peq (n + len1)) bind1 bind2)
peq n (BLam _ f1) (BLam _ f2) = peq n (f1 0) (f2 0) -- 0 for type index, OK?
peq n (App e1 e2) (App g1 g2) = peq n e1 g1 && peq n e2 g2
peq n (TApp e1 _) (TApp e2 _) = peq n e1 e2
peq n (If e1 e2 e3) (If g1 g2 g3) = peq n e1 g1 && peq n e2 g2 && peq n e3 g3
peq n (PrimOp e1 _ e2) (PrimOp g1 _ g2) = peq n e1 g1 && peq n e2 g2
peq n (Tuple es) (Tuple gs) =
  let len1 = length es
      len2 = length gs
  in len1 == len2 && and (zipWith (peq n) es gs)
peq n (Proj _ e) (Proj _ g) = peq n e g
peq n (JNew _ es) (JNew _ gs) =
  let len1 = length es
      len2 = length gs
  in len1 == len2 && and (zipWith (peq n) es gs)
peq n (JMethod e1 _ es _) (JMethod g1 _ gs _) =
  let len1 = length es
      len2 = length gs
  in len1 == len2 && checkCall n e1 g1 && and (zipWith (peq n) es gs)
peq n (JField e1 _ _) (JField g1 _ _) = checkCall n e1 g1
peq n (Error _ str1) (Error _ str2) = peq n str1 str2
peq n (Seq es) (Seq gs) = and (zipWith (peq n) es gs)
peq _ _ _ = False

checkCall :: Int -> Src.JReceiver (Expr Int Int) -> Src.JReceiver (Expr Int Int) -> Bool
checkCall _ (Src.Static s1) (Src.Static s2) = s1 == s2
checkCall n (Src.NonStatic e1) (Src.NonStatic e2) = peq n e1 e2
checkCall _ _ _ = False

multInsert :: Map.Map Int e -> (Int, e) -> Map.Map Int e
multInsert m (key, value) = Map.insert key value m


<|start_filename|>runtime/src/f2j/tuples/Tuple3.java<|end_filename|>
package f2j.tuples;

public class Tuple3 {
    public final Object _1, _2, _3;

    public Tuple3(Object _1, Object _2, Object _3) {
        this._1 = _1;
        this._2 = _2;
        this._3 = _3;
    }
}


<|start_filename|>testsuite/tests/SrcTests.hs<|end_filename|>
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module SrcTests where

import Test.Tasty
import Test.Tasty.HUnit

import Src

import qualified Data.Map as Map

srcTests = testGroup "Src" [compatibleTests, groupForallTests]

compatibleTests = testGroup "compatible"
  [ testCase "A = A" $
      compatible (Map.fromList [("A", (Star, TerminalType))]) a a @?= True
  ]

groupForallTests = testGroup "groupForall"
  [ testCase "forall A. forall B. A -> B" $
      groupForall (forallAB (a `Fun` b)) @?= (["A", "B"], a `Fun` b)

  , testCase "forall A. forall B. A -> (forall A. A)" $
      groupForall (forallAB (a `Fun` forallA a)) @?= (["A", "B"], a `Fun` forallA a)
  ]

forallA  = Forall "A"
forallAB = Forall "A" . Forall "B"
a = TVar "A"
b = TVar "B"


<|start_filename|>frontend/simplify/SimplifyImpl.hs<|end_filename|>
{-# LANGUAGE TypeOperators, FlexibleInstances, MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
{- |
Module      :  Simplify
Description :  The simplifier turns SystemFI into Core.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>, <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable

The simplifier translates System F with intersection types to vanilla System F.
-}

module SimplifyImpl
  ( simplify
  , simplify'
  , infer
  , transExpr
  , transType
  , coerce
  , dedeBruT
  , dedeBruE
  ) where

import           Core
import           Panic
import qualified Src as S
import qualified SystemFI as FI

import           Control.Arrow (second)
import           Control.Monad (zipWithM)
import           Data.Maybe (fromMaybe)
import           Debug.Trace (trace)
import           Prelude hiding ((<$>))
import           Text.PrettyPrint.ANSI.Leijen
import           Unsafe.Coerce (unsafeCoerce)

simplify :: FI.FExp -> Expr t e
simplify = dedeBruE 0 [] 0 [] . transExpr 0 0 . FI.revealF

simplify' :: FI.Expr t e -> Expr t e
simplify' = dedeBruE 0 [] 0 [] . transExpr 0 0 . unsafeCoerce

infer :: Index -> Index -> FI.Expr Index (Index, FI.Type Index) -> FI.Type Index
infer i j (FI.Var _ (_, t))       = t
infer i j (FI.Lit (S.Int    _))   = FI.JClass "java.lang.Integer"
infer i j (FI.Lit (S.String _))   = FI.JClass "java.lang.String"
infer i j (FI.Lit (S.Bool   _))   = FI.JClass "java.lang.Boolean"
infer i j (FI.Lit (S.Char   _))   = FI.JClass "java.lang.Character"
infer i j (FI.Lit  S.UnitLit)     = FI.Unit
infer i j (FI.Lam n t f)          = FI.Fun t . infer i (j + 1) $ f (j, t)
infer i j (FI.Fix _ _ _ t1 t)     = FI.Fun t1 t
infer i j (FI.Let _ b f)          = infer i (j + 1) $ f (j, infer i j b)
infer i j (FI.LetRec _ ts _ e)    = infer i (j + n) $ e (zip [j..j+n-1] ts)      where n = length ts
infer i j (FI.BLam n f)           = FI.Forall n (\a -> infer (i + 1) j $ f a)
infer i j (FI.App f x)            = t                                            where FI.Fun _ t = infer i j f
infer i j (FI.TApp f x)           = FI.mapTVar (\n1 a1 -> if a1 == i + 10000 && n1 == n then x else FI.TVar n1 a1) (g (i + 10000))
  where FI.Forall n g = infer (i + 1) j f
  -- Warning! Workaround: please use distinct names for sorts.
infer i j (FI.If _ e _)           = infer i j e
infer i j (FI.PrimOp _ op _)      = case op of S.Arith   _ -> FI.JClass "java.lang.Integer"
                                               S.Compare _ -> FI.JClass "java.lang.Boolean"
                                               S.Logic   _ -> FI.JClass "java.lang.Boolean"
infer i j (FI.Tuple es)           = FI.Product . map (infer i j) $ es
infer i j (FI.Proj index e)       = ts !! (index - 1)                            where FI.Product ts = infer i j e
infer i j (FI.JNew c _)           = FI.JClass c
infer i j (FI.JMethod _ _ _ c)    = FI.JClass c
infer i j (FI.JField _ _ c)       = c
infer i j (FI.Seq es)             = infer i j (last es)
infer i j (FI.Merge e1 e2)        = FI.And (infer i j e1) (infer i j e2)
infer i j (FI.RecordCon (l, e))   = FI.RecordType (l, infer i j e)
infer i j (FI.RecordProj e l1)    = t1                                           where Just (t1, _) = getter i j (infer i j e) l1
infer i j (FI.RecordUpdate e _)   = infer i j e
infer _ _ (FI.Error ty _)         = ty
infer i j (FI.ConstrOut c _)         = last . FI.constrParams $ c
infer i j (FI.Case _ alts)        = inferAlt . head $ alts
  where inferAlt (FI.ConstrAlt _ e) = infer i j e
        inferAlt (FI.Default e)       = infer i j e
infer i j (FI.Data _ _ e)         = infer i j e
infer _ _ _                       = trace "Unsupported: Simplify.infer" FI.Unit

transExpr :: Index -> Index -> FI.Expr Index (Index, FI.Type Index) -> Expr Index Index
transExpr i j (FI.Var n (x, _))          = Var n x
transExpr i j (FI.Lit l)                 = Lit l
transExpr i j (FI.Lam n t f)             = Lam n (transType i t) (\x -> transExpr i (j + 1) $ f (x, t))
transExpr i j this@(FI.Fix fn pn e t1 t) = Fix fn pn e' t1' t'
  where
    e'        = \x x1 -> transExpr i (j + 2) $ e (x, infer i j this) (x1, t1)
    (t1', t') = (transType i t1, transType i t)
transExpr i j (FI.Let n b f)             = Let n (transExpr i j b) (\x -> transExpr i (j + 1) $ f (x, infer i j b))
transExpr i j (FI.LetRec ns ts bs e)     = LetRec ns ts' bs' e'
  where
    ts' = map (transType i) ts
    bs' args = map (transExpr i (j + n)) . bs $ zip args ts
    e'  args = transExpr i (j + n) . e $ zip args ts
    n = length ts
transExpr i j (FI.BLam n f)              = BLam n (\a -> transExpr (i + 1) j $ f a)
transExpr i j (FI.App f x) =
  let (FI.Fun t1 t2, e1) = (infer i j f, transExpr i j f)
      (t3, e2)           = (infer i j x, transExpr i j x)
      panic_doc          = text "Coercion failed" <$>
                           text "Function: " <> pretty_typing f (FI.Fun t1 t2) <$>
                           text "Argument: " <> pretty_typing x t3 <$>
                           text "Coercion: " <> pretty_coercion t3 t1
      pretty_typing temp1 temp2   = FI.prettyExpr (unsafeCoerce temp1 :: FI.Expr Index Index) <+> colon <+>
                                    FI.prettyType (unsafeCoerce temp2 :: FI.Type Index)
      pretty_coercion temp1 temp2 = FI.prettyType (unsafeCoerce temp1 :: FI.Type Index) <+> text "<:" <+>
                                    FI.prettyType (unsafeCoerce temp2 :: FI.Type Index)
  in let c = fromMaybe (prettyPanic "Simplify.transExpr" panic_doc) (coerce i t3 t1)
     in App e1 (App c e2)
transExpr i j (FI.TApp f x)                = TApp (transExpr i j f) (transType i x)
transExpr i j (FI.If e1 e2 e3)             = If e1' e2' e3'
  where [e1', e2', e3'] = map (transExpr i j) [e1, e2, e3]
transExpr i j (FI.PrimOp e1 op e2)         = PrimOp (transExpr i j e1) op (transExpr i j e2)
transExpr i j (FI.Tuple es)                = Tuple . map (transExpr i j) $ es
transExpr i j (FI.Proj index e)            = Proj index $ transExpr i j e
transExpr i j (FI.Module pname defs) = Module pname $ transDefs i j defs
  where
    transDefs i j (FI.Def n (t, t') expr def) = Def n t (transExpr i j expr)
                                            (\x -> transDefs i (j + 1) $ def (x, t'))
    transDefs i j (FI.DefRec names types exprs def) = DefRec names types' exprs' def'
      where types' = map (second (transType i)) types
            exprs' args = map (transExpr i (j + n)) . exprs $ zip args ts
            def' args = transDefs i (j + n) . def $ zip args ts
            ts = map snd types
            n = length types

    transDefs _ _ FI.Null = Null
transExpr i j (FI.JNew c es)               = JNew c . map (transExpr i j) $ es
transExpr i j (FI.JMethod c m arg ret)     = JMethod (fmap (transExpr i j) c) m (map (transExpr i j) arg) ret
transExpr i j (FI.JField c m ret)          = JField (fmap (transExpr i j) c) m (transType i ret)
transExpr i j (FI.Seq es)                  = Seq . map (transExpr i j) $ es
transExpr i j (FI.Merge e1 e2)             = Tuple . map (transExpr i j) $ [e1, e2]
transExpr i j (FI.RecordCon (l, e))        = transExpr i j e
transExpr i j (FI.RecordProj e l1)         = App c $ transExpr i j e
  where Just (_, c) = getter i j (infer i j e) l1
transExpr i j (FI.RecordUpdate e (l1, e1)) = App c $ transExpr i j e
  where Just (_, c) = putter i j (infer i j e) l1 (transExpr i j e1)
transExpr i j (FI.ConstrOut (FI.Constructor n ts) es) = ConstrOut (Constructor n . map (transType i) $ ts) . map (transExpr i j) $ es
transExpr i j (FI.Case e alts)             = Case e' . map transAlt $ alts
  where
    e' = transExpr i j e
    transAlt (FI.ConstrAlt (FI.Constructor n ts) e1) =
      ConstrAlt (Constructor n (map (transType i) ts)) (transExpr i i e1)
    transAlt (FI.Default e1) = Default (transExpr i j e1)
transExpr i j (FI.Error ty str)            = Error (transType i ty) (transExpr i j str)
transExpr i j (FI.Data recflag databinds e)= Data recflag (map transDatabind databinds) (transExpr i j e)
  where transCtr (FI.Constructor name cps) = Constructor name . map (transType i) $ cps
        transDatabind (FI.DataBind n params ctrs) = DataBind n params (map transCtr . ctrs)
transExpr _ _ _                            = trace "Unsupported: Simplify.transExpr" (Var "" (-1))

transType :: Index -> FI.Type Index -> Type Index
transType i (FI.TVar n a)          = TVar n a
transType i (FI.JClass c)          = JClass c
transType i (FI.Fun a1 a2)         = Fun (transType i a1) (transType i a2)
transType i (FI.Forall n f)        = Forall n (\a -> transType (i + 1) $ f a)
transType i (FI.Product ts)        = Product . map (transType i) $ ts
transType i (FI.Unit)              = Unit
transType i (FI.And a1 a2)         = Product . map (transType i) $ [a1, a2]
transType i (FI.RecordType (_, t)) = transType i t
transType i (FI.Datatype n ts ns)  = Datatype n (map (transType i) ts) ns
transType _ _                      = trace "Unsupported: Simplify.transType" (TVar "" (-1))

coerce :: Index -> FI.Type Index -> FI.Type Index -> Maybe (Expr Index Index)
coerce i this@(FI.TVar _ a) (FI.TVar _ b)
  | a == b = return $ lam (transType i this) var
  | otherwise = Nothing
coerce i this@(FI.JClass c) (FI.JClass d)
  | c == d = return $ lam (transType i this) var
  | otherwise = Nothing
coerce i this@(FI.Fun t1 t2) (FI.Fun t3 t4) = do
  c1 <- coerce i t3 t1
  c2 <- coerce i t2 t4
  return $ lam (transType i this) (\f -> lam (transType i t3) $ (App c2 . App (var f) . App c1) . var)
coerce i this@(FI.Forall _ f) (FI.Forall _ g) = do
  c <- coerce (i + 1) (f i) (g i)
  return $ lam (transType i this) (\f' -> bLam $ (App c . TApp (var f')) . TVar "_")
coerce i this@(FI.Product ss) (FI.Product ts)
  | length ss /= length ts = Nothing
  | otherwise = do
      cs <- zipWithM (coerce i) ss ts
      let f x = Tuple $ zipWith (\c idx -> App c $ Proj idx x) cs [1..length ss]
      return $ lam (transType i this) (f . var)
coerce i this@(FI.Unit) (FI.Unit) = return $ lam (transType i this) var
coerce i t1 (FI.And t2 t3) = do
  c1 <- coerce i t1 t2
  c2 <- coerce i t1 t3
  return $ lam (transType i t1) (\x -> Tuple [App c1 (var x), App c2 (var x)])
coerce i this@(FI.And t1 t2) t3 =
  case coerce i t1 t3 of
    Just c  -> return $ lam (transType i this) (App c . Proj 1 . var)
    Nothing -> case coerce i t2 t3 of
                 Just c  -> return $ lam (transType i this) (App c . Proj 2 . var)
                 Nothing -> Nothing
coerce i (FI.RecordType (l1, t1)) (FI.RecordType (l2, t2))
  | l1 == l2  = coerce i t1 t2
  | otherwise = Nothing
coerce i this@(FI.Datatype n1 _ _) (FI.Datatype n2 _ _)
  | n1 == n2  = return $ lam (transType i this) var
  | otherwise = Nothing
coerce _ _ _ = Nothing

getter :: Index -> Index -> FI.Type Index -> S.Label -> Maybe (FI.Type Index, Expr Index Index)
getter i j this@(FI.RecordType (l, t)) l1
  | l1 == l = return $ (t, lam (transType i this) var)
  | otherwise = Nothing
getter i j this@(FI.And t1 t2) l =
  case getter i j t2 l of
    Just (t, c) -> return $ (t, lam (transType i this) (App c . Proj 2 . var))
    Nothing     -> case getter i j t1 l of
                     Just (t, c) -> return $ (t, lam (transType i this) (App c . Proj 1 . var))
                     Nothing     -> Nothing
getter _ _ _ _ = Nothing

putter :: Index -> Index -> FI.Type Index -> S.Label -> Expr Index Index -> Maybe (FI.Type Index, Expr Index Index)
putter i j this@(FI.RecordType (l, t)) l1 e
  | l1 == l = return $ (t, lam (transType i this) (const e))
  | otherwise = Nothing
putter i j this@(FI.And t1 t2) l e =
  case putter i j t2 l e of
    Just (t, c) -> return $ (t, lam (transType i this) (\x -> Tuple [Proj 1 . var $ x, App c . Proj 2 . var $ x]))
    Nothing     -> case putter i j t1 l e of
                     Just (t, c) -> return $ (t, lam (transType i this) (\x -> Tuple [App c . Proj 1 . var $ x, Proj 2 . var $ x]))
                     Nothing     -> Nothing
putter _ _ _ _ _ = Nothing

subst :: (S.Name -> Index -> FI.Type Index) -> [FI.Type Index] -> FI.Type Index
subst g ts@((FI.TVar n a):_)      = if constr then g n a else FI.TVar n a
  where constr = all (== a) . map (\x -> let FI.TVar _ y = x in y) $ ts
subst g ((FI.JClass c):_)         = FI.JClass c
subst g ts@((FI.Fun _ _):_)       = FI.Fun (subst g ts1) (subst g ts2)
  where (ts1, ts2) = unzip . map (\x -> let FI.Fun t1 t2 = x in (t1, t2)) $ ts
subst g ts@((FI.Forall n _):_)    = FI.Forall n (\z -> subst g $ ts' z)
  where ts' z = concat . map (\x -> let FI.Forall _ f = x in [f z, f (z + 1)]) $ ts
subst g ts@((FI.Product _):_)     = FI.Product ts'
  where
    ts' = map (subst g) . transpose . map (\x -> let FI.Product hs = x in hs) $ ts
    transpose :: [[a]] -> [[a]]
    transpose [] = []
    transpose xs = (map head xs):(transpose . map tail $ xs)
subst g (FI.Unit:_)             = FI.Unit
subst g ts@((FI.And _ _):_)       = FI.And (subst g ts1) (subst g ts2)
  where (ts1, ts2) = unzip . map (\x -> let FI.And t1 t2 = x in (t1, t2)) $ ts
subst g ts@((FI.RecordType (l, _)):_) = FI.RecordType (l, t')
  where t' = subst g . map (\x -> let FI.RecordType (_, t) = x in t) $ ts
subst g ts@((FI.Datatype n _ ns):_) = FI.Datatype n ts' ns
  where
    ts' = map (subst g) . transpose . map (\x -> let FI.Datatype _ hs _ = x in hs) $ ts
    transpose :: [[a]] -> [[a]]
    transpose [] = []
    transpose xs = (map head xs):(transpose . map tail $ xs)

substTT :: Index -> FI.Type Index -> FI.Type Index -> FI.Type Index
substTT i x t = subst (\n a -> if a == i then x else FI.TVar n a) [t]

dedeBruT :: Index -> [t] -> Type Index -> Type t
dedeBruT _ as (TVar n i)         = TVar n (reverse as !! i)
dedeBruT _ _  (JClass c)         = JClass c
dedeBruT i as (Fun t1 t2)        = Fun (dedeBruT i as t1) (dedeBruT i as t2)
dedeBruT i as (Forall n f)       = Forall n (\a -> dedeBruT (i + 1) (a:as) (f i))
dedeBruT i as (Product ts)       = Product (map (dedeBruT i as) ts)
dedeBruT i as (Datatype n ts ns) = Datatype n (map (dedeBruT i as) ts) ns
dedeBruT i as  Unit              = Unit

dedeBruE :: Index -> [t] -> Index -> [e] -> Expr Index Index -> Expr t e
dedeBruE _ _  _ xs (Var n i)                      = Var n (reverse xs !! i)
dedeBruE _ _  _ _  (Lit l)                        = Lit l
dedeBruE i as j xs (Lam n t f)                    = Lam n
                                                      (dedeBruT i as t)
                                                      (\x -> dedeBruE i as (j + 1) (x:xs) (f j))
dedeBruE i as j xs (Fix fn pn f t1 t)             = Fix fn pn
                                                      (\x x1 -> dedeBruE i as (j + 2) (x1:x:xs) $ f j (j + 1))
                                                      (dedeBruT i as t1)
                                                      (dedeBruT i as t)
dedeBruE i as j xs (Let n e f)                    = Let n
                                                      (dedeBruE i as j xs e)
                                                      (\x -> dedeBruE i as (j + 1) (x:xs) (f j))
dedeBruE i as j xs (LetRec ns ts fs e)            = LetRec ns
                                                      (map (dedeBruT i as) ts)
                                                      (\xs' -> map (dedeBruE i as (j + n) ((reverse xs') ++ xs)) (fs [j..j + n - 1]))
                                                      (\xs' -> dedeBruE i as (j + n) ((reverse xs') ++ xs) (e [j..j + n - 1]))
                                                      where n = length ts
dedeBruE i as j xs (BLam n f)                     = BLam n (\a -> dedeBruE (i + 1) (a:as) j xs (f i))
dedeBruE i as j xs (App f x)                      = App
                                                      (dedeBruE i as j xs f)
                                                      (dedeBruE i as j xs x)
dedeBruE i as j xs (TApp f a)                     = TApp
                                                       (dedeBruE i as j xs f)
                                                       (dedeBruT i as a)
dedeBruE i as j xs (If p b1 b2)                   = If p' b1' b2' where [p',b1',b2'] = map (dedeBruE i as j xs) [p,b1,b2]
dedeBruE i as j xs (PrimOp e1 op e2)              = PrimOp
                                                      (dedeBruE i as j xs e1) op
                                                      (dedeBruE i as j xs e2)
dedeBruE i as j xs (Tuple es)                     = Tuple (map (dedeBruE i as j xs) es)
dedeBruE i as j xs (Module pname defs) = Module pname (dedeBruDefs i as j xs defs)
  where
    dedeBruDefs i as j xs (Def n t expr def) = Def n t (dedeBruE i as j xs expr)
                                                 (\f -> dedeBruDefs i as (j + 1) (f : xs) (def j))
    dedeBruDefs i as j xs (DefRec names types exprs def) = DefRec names types' exprs' def'
      where
        ts = map snd types
        types' = map (second (dedeBruT i as)) types
        exprs' args = map (dedeBruE i as (j + n) ((reverse args) ++ xs)) (exprs [j .. j + n - 1])
        def' args = dedeBruDefs i as (j + n) ((reverse args) ++ xs) (def [j .. j + n - 1])
        n = length types
    dedeBruDefs _ _ _ _ Null = Null
dedeBruE i as j xs (Proj index e)                 = Proj index (dedeBruE i as j xs e)
dedeBruE i as j xs (JNew c args)                  = JNew c (map (dedeBruE i as j xs) args)
dedeBruE i as j xs (JMethod callee m args r)      = JMethod
                                                      (fmap (dedeBruE i as j xs) callee) m
                                                      (map (dedeBruE i as j xs) args) r
dedeBruE i as j xs (JField callee f r)            = JField (fmap (dedeBruE i as j xs) callee) f (dedeBruT i as r)
dedeBruE i as j xs (Seq es)                       = Seq (map (dedeBruE i as j xs) es)
dedeBruE i as j xs (ConstrOut (Constructor n ts) es) = ConstrOut
                                                      (Constructor n (map (dedeBruT i as) ts))
                                                      (map (dedeBruE i as j xs) es)
dedeBruE i as j xs (Case e alts)                  = Case (dedeBruE i as j xs e) (map dedeBruijnAlt alts)
  where dedeBruijnAlt (ConstrAlt (Constructor name ts) e1) =
          ConstrAlt (Constructor name (map (dedeBruT i as) ts)) (dedeBruE i as j xs e1)
        dedeBruijnAlt (Default e1) = Default (dedeBruE i as j xs e1)

dedeBruE i as j xs (Data recflag databinds e)     = Data recflag (map dedeBruijnDatabind databinds) (dedeBruE i as j xs e)
  where dedeBruijnConstr i' as' (Constructor name types) = Constructor name (map (dedeBruT i' as') types)
        dedeBruijnDatabind (DataBind n ns ctrs)   = DataBind n ns (\a -> map (dedeBruijnConstr (length ns + i) (a++as)) $
                                                                         (ctrs [i..length ns+i-1]) )

dedeBruE i as j xs (Error ty str)                 = Error (dedeBruT i as ty) (dedeBruE i as j xs str)


<|start_filename|>frontend/abstractsyntax/Src.hs<|end_filename|>
{- |
Module      :  Src
Description :  Abstract syntax and pretty printer for the source language.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3
Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Src
  ( Program(..), Declaration(..)
  , Module(..), ModulePath, ReadModule, Import(..), PoorMensImport(..), ReadImport, ModuleBind(..), ReadModuleBind, Definition(..), CheckedBind
  , Kind(..)
  , Type(..)
  , Expr(..), ParsedExpr, CheckedExpr, LExpr
  , Constructor(..), Alt(..), Pattern(..)
  , Bind(..), ReadBind
  , RecFlag(..), Lit(..), Operator(..), UnitPossibility(..), JReceiver(..), Label
  , Name, CheckedId, PackageName
  , TypeValue(..), TypeContext, ValueContext, ModuleContext, ModuleMapInfo
  , TypeBind(..), DataBind(..)
  , liftExprToDecl
  , groupForall
  , expandType

  -- Relations between types
  , subtype
  , compatible
  , leastUpperBound

  , recordFields
  , freeTVars
  , fsubstTT
  , wrap
  , opPrec
  , intersperseBar

  , isWildcardOrVar
  , constrInfo
  , extractorsubpattern
  , specializedMatrix
  , defaultMatrix

  , addTVarToContext
  , addConstrainedTVarToContext
  , addTypeSynonym
  , addVarToContext
  , addModuleInfo
  , lookupTVarConstraint
  , lookupVarType
  ) where

import           Config
import           JavaUtils
import           Panic
import           PrettyUtils
import           SrcLoc

import           Control.Arrow (second)
import           Data.Data
import           Data.List (intersperse, findIndex, nub)
import qualified Data.Map as Map
import           Data.Maybe (fromJust)
import qualified Data.Set as Set
import           GHC.Generics (Generic)
import qualified Language.Java.Syntax as J (Op(..))
import           Prelude hiding ((<$>))
import           Text.PrettyPrint.ANSI.Leijen

-- Names and identifiers.
type Name      = String
type CheckedId = (Name, Type)
type Label     = Name


data Program = Program
  { pgmImports :: [Import]
  , pgmDecls   :: [Declaration]
  } deriving (Show)

data Declaration
  = DefDecl ReadBind
  | TypeDecl TypeBind
  | DataDecl DataBind
  deriving (Show)

data Import = Import
  { importModulePath :: Located ModulePath
  } deriving (Show)

type ModulePath = String

-- Modules.
data ModuleBind id ty = BindNonRec (Bind id ty)
                      | BindRec [Bind id ty] deriving (Eq, Show)
data Module id ty = Module [PoorMensImport id] [ModuleBind id ty] deriving (Eq, Show)

type ReadModule = Module Name Type
type ReadModuleBind = ModuleBind Name Type
data PoorMensImport id = PoorMensImport id deriving (Eq, Show)
type ReadImport = Located (PoorMensImport Name)

-- Kinds k := * | k -> k
data Kind = Star | KArrow Kind Kind deriving (Eq, Show)

-- Types.
data Type
  = TVar Name
  | JClass ClassName
  | Unit
  | Fun Type Type
  | Forall (Name, Maybe Type) Type
  | TupleType [Type]
  -- Extensions
  | And Type Type
  | RecordType [(Label, Type)]

  -- Type synonyms
  | OpAbs Name Type -- Type-level abstraction: "type T A = t" becomes "type T = \A. t", and "\A. t" is the abstraction.
  | OpApp Type Type -- Type-level application: t1 t2

  | Datatype Name [Type] [Name]

  -- Warning: If you ever add a case to this, you MUST also define the binary
  -- relations on your new case. Namely, add cases for your data constructor in
  -- `compatible` and `subtype` below.
  deriving (Eq, Show, Data, Typeable, Read, Generic)

type LExpr id ty = Located (Expr id ty)

-- Expressions.
data Expr id ty
  = Var id                                    -- Variable
  | Lit Lit                                   -- Literals
  | Lam (Located Name, ty) (LExpr id ty) -- Lambda
  | App (LExpr id ty) (LExpr id ty)            -- Application
  | BLam (Name, Maybe Type) (LExpr id ty)                    -- Big lambda
  | TApp (LExpr id ty) ty                    -- Type application
  | TupleCon [LExpr id ty]                        -- Tuples
  | TupleProj (LExpr id ty) Int                     -- Tuple projection
  | PrimOp (LExpr id ty) Operator (LExpr id ty) -- Primitive operation
  | If (LExpr id ty) (LExpr id ty) (LExpr id ty) -- If expression
  | LetIn RecFlag [Bind id ty] (LExpr id ty)     -- Let (rec) ... (and) ... in ...
  | LetOut                                    -- Post typecheck only
      RecFlag
      [(Name, Type, CheckedExpr)]
      (LExpr (Name,Type) Type)

  | Dot (LExpr id ty) Name (Maybe ([LExpr id ty], UnitPossibility))
  -- The flag `UnitPossibility` is only used when length of the argument list is
  -- 0, to distinguish the different possible interpretations of `e.x ( )` and
  -- `e.x ()` -- the latter can be an application (of unit literal to a record
  -- elim), while the former cannot.

  | JNew ClassName [LExpr id ty]
  | JMethod (JReceiver (LExpr id ty)) MethodName [LExpr id ty] ClassName
  | JField  (JReceiver (LExpr id ty)) FieldName            Type
  | Seq [LExpr id ty]
  | PolyList [LExpr id ty]
  | Merge (LExpr id ty) (LExpr id ty)
  | RecordCon [(Label, LExpr id ty)]
  | RecordProj (LExpr id ty) Label
  | RecordUpdate (LExpr id ty) [(Label, LExpr id ty)]
  | Type TypeBind (LExpr id ty)
  | Data RecFlag [DataBind] (LExpr id ty)
  | Case (LExpr id ty) [Alt id ty]
  | CaseString (LExpr id ty) [Alt id ty] --pattern match on string
  | ConstrIn Name
  | ConstrOut Constructor [LExpr id ty] -- post typecheck only
                                     -- the last type in Constructor will always be the real type
  | Error Type (LExpr id ty)
  deriving (Eq, Show)

type PackageName = Name
type CheckedBind = (Name, Type, CheckedExpr)
data Definition = Def CheckedBind | DefRec [CheckedBind] deriving (Eq, Show)

-- type T[A1, ..., An] = t
data TypeBind = TypeBind
  { typeBindName   :: Name   -- T
  , typeBindParams :: [Name] -- A1, ..., An
  , typeBindRhs    :: Type   -- t
  } deriving (Eq, Show)

data DataBind = DataBind Name [Name] [Constructor] deriving (Eq, Show)
data Constructor = Constructor {constrName :: Name, constrParams :: [Type]}
                   deriving (Eq, Show)

data Alt id ty = ConstrAlt Pattern (LExpr id ty)
            -- | Default (Expr id)
              deriving (Eq, Show)

data Pattern = PConstr Constructor [Pattern]
             | PVar Name Type
             | PWildcard
             deriving (Eq, Show)

-- type RdrExpr = Expr Name
type ParsedExpr  = LExpr Name Type
type CheckedExpr = LExpr CheckedId Type
-- type TcExpr  = Expr TcId
-- type TcBinds = [(Name, Type, Expr TcId)] -- f1 : t1 = e1 and ... and fn : tn = en

data Lit -- Data constructor names match Haskell types
  = Int Integer
  | String String
  | Bool Bool
  | Char Char
  | UnitLit
  deriving (Eq, Show, Generic)

data Operator = Arith J.Op | Compare J.Op | Logic J.Op deriving (Eq, Show, Generic, Typeable)

-- f[A1,...,An](x1: t1, ..., xn: tn): t = e
data Bind id ty = Bind
  { bindName     :: id                   -- f
  , bindTyParams :: [(Name, Maybe Type)] -- A1, ..., An
  , bindParams   :: [(Located Name, Type)] -- x1: t1, ..., xn: tn
  , bindRhs      :: LExpr id ty          -- e
  , bindRhsTyAscription :: Maybe Type    -- t
  } deriving (Eq, Show)

type ReadBind = Bind Name Type

data RecFlag = Rec | NonRec deriving (Eq, Show)
data UnitPossibility = UnitPossible | UnitImpossible deriving (Eq, Show)

data JReceiver e = Static ClassName | NonStatic e deriving (Eq, Show)

instance Functor JReceiver where
  fmap _ (Static c)    = Static c
  fmap f (NonStatic e) = NonStatic (f e)


-- Type and value contexts

-- `TypeValue` is what's put inside a type context.
data TypeValue
  = TerminalType -- Terminal types, e.g., the `a` of `forall a. `
  | NonTerminalType Type
    -- Non-terminal types, i.e. type synoyms. `Type` holds the RHS to the
    -- equal sign of type synonym definitions.

type TypeContext  = Map.Map Name ( Kind
                                   , Maybe Type -- Constraint
                                   , TypeValue
                                   ) -- Delta
type ValueContext = Map.Map Name Type              -- Gamma
type ModuleMapInfo = (Maybe PackageName, Type, Name, Name)
type ModuleContext = Map.Map Name ModuleMapInfo -- Sigma


liftExprToDecl :: Name -> ParsedExpr -> Declaration
liftExprToDecl name expr = DefDecl bind
  where
    bind = Bind { bindName     = name
                , bindTyParams = []
                , bindParams   = [] -- TODO: should be a () as in `main()`
                , bindRhs      = expr
                , bindRhsTyAscription = Nothing
                }

addTVarToContext :: [(Name, Kind)] -> TypeContext -> TypeContext
addTVarToContext tvars d =
  let tvars' = map (\(id, kd) -> (id, (kd, Nothing, TerminalType))) tvars
  in Map.fromList tvars' `Map.union` d
         -- `Map.fromList` is right-biased and `Map.union` is left-biased.

addConstrainedTVarToContext :: [(Name, Maybe Type)] -> TypeContext -> TypeContext
addConstrainedTVarToContext tvars d
  = let tvars' = map (\(id, constraint) -> (id, (Star, constraint, TerminalType))) tvars
    in Map.fromList tvars' `Map.union` d
           -- `Map.fromList` is right-biased and `Map.union` is left-biased.

addTypeSynonym :: [(Name, Type, Kind)] -> TypeContext -> TypeContext
addTypeSynonym tvars d =
  let tvars' = map (\(id, ty, kd) -> (id, (kd, Nothing, NonTerminalType ty))) tvars
  in  Map.fromList tvars' `Map.union` d

addVarToContext :: [(Name, Type)] -> ValueContext -> ValueContext
addVarToContext vars d = Map.fromList vars `Map.union` d

addModuleInfo ::  [(Name, ModuleMapInfo)] -> ModuleContext -> ModuleContext
addModuleInfo info m = Map.fromList info `Map.union` m

lookupTVarConstraint :: TypeContext -> Name -> Maybe Type
lookupTVarConstraint d id
  = case Map.lookup id d of
      Nothing      -> Nothing
      Just (_,c,_) -> c

lookupVarType :: Name -> ValueContext -> Maybe Type
lookupVarType id d = Map.lookup id d

-- | Recursively expand all type synonyms. The given type must be well-kinded.
-- Used in `compatible` and `subtype`.
expandType :: TypeContext -> Type -> Type

-- Interesting cases:
expandType d (TVar a)
  = case Map.lookup a d of
      Nothing                          -> prettyPanic "expandType" (pretty (TVar a))
      Just (_, _, TerminalType)        -> TVar a
      Just (_, _, NonTerminalType def) -> expandType d def
expandType d (OpAbs x t) = OpAbs x (expandType (addTVarToContext [(x, Star)] d) t)
expandType d (OpApp t1 t2)
  = let t1' = expandType d t1
        t2' = expandType d t2
    in
    case t1' of
      OpAbs x t -> fsubstTT (x,t2') t

-- Uninteresting cases:
expandType _ (JClass c)   = JClass c
expandType _ Unit         = Unit
expandType d (Fun t1 t2)  = Fun (expandType d t1) (expandType d t2)
expandType d (Forall (a,c) t) = Forall (a, fmap (expandType d) c) (expandType (addTVarToContext [(a, Star)] d) t)
expandType d (TupleType ts) = TupleType (map (expandType d) ts)
expandType d (RecordType fs)  = RecordType (map (second (expandType d)) fs)
expandType d (And t1 t2)  = And (expandType d t1) (expandType d t2)
expandType d (Datatype n ts ns) = Datatype n (map (expandType d) ts) ns


-- Relations between types

-- | Subtyping (<:) is defined only between types of kind *.
subtype :: TypeContext -> Type -> Type -> Bool
subtype d t1 t2 = subtypeS (expandType d t1) (expandType d t2)

-- | Subtyping of two *expanded* types.
subtypeS :: Type -> Type -> Bool
subtypeS (TVar a)       (TVar b)               = a == b
subtypeS (JClass c)     (JClass d)             = c == d
-- The subtypeS here shouldn't be aware of the subtyping relations in the Java world.
subtypeS (Fun t1 t2)    (Fun t3 t4)            = subtypeS t3 t1 && subtypeS t2 t4

subtypeS (Forall (a1,Nothing) t1) (Forall (a2,_) t2) = subtypeS (fsubstTT (a1,TVar a2) t1) t2
subtypeS (Forall (a1,Just c1) t1) (Forall (a2,Nothing) t2) = False
subtypeS (Forall (a1,Just c1) t1) (Forall (a2,Just c2) t2)
  = subtypeS c2 c1 && subtypeS (fsubstTT (a1,TVar a2) t1) t2

subtypeS (TupleType ts1) (TupleType ts2)       = length ts1 == length ts2 && uncurry subtypeS `all` zip ts1 ts2
subtypeS (RecordType [(l1,t1)]) (RecordType [(l2,t2)]) = l1 == l2 && subtypeS t1 t2
subtypeS (RecordType fs1)   (RecordType fs2)           = subtypeS (desugarMultiRecordType fs1) (desugarMultiRecordType fs2)
-- The order is significant for the two `And` cases below.
subtypeS t1             (And t2 t3) = subtypeS t1 t2 && subtypeS t1 t3
subtypeS (And t1 t2)    t3          = subtypeS t1 t3 || subtypeS t2 t3
subtypeS Unit           Unit        = True
subtypeS (Datatype n1 ts1 m1) (Datatype n2 ts2 m2) =
    n1 == n2 && m1 == m2 && length ts1 == length ts2 && uncurry subtypeS `all` zip ts1 ts2
subtypeS t1             t2          = False `panicOnSameDataCons` ("Src.subtypeS", t1, t2)


-- | Two types are called "compatible" iff they are subtype of each other.
compatible :: TypeContext -> Type -> Type -> Bool
compatible d t1 t2 = subtype d t1' t2' && subtype d t2' t1'
  where
    t1' = expandType d t1
    t2' = expandType d t2

-- | Computes the least upper bound of two types.
leastUpperBound :: TypeContext -> Type -> Type -> Maybe Type
leastUpperBound d t1 t2
  | subtype d t1 t2 = Just t2
  | subtype d t2 t1 = Just t1
  | otherwise       = Nothing


-- Records

-- TODO: refactor the following two functions

desugarRecordType :: Type -> Type
desugarRecordType (RecordType [(l,t)]) = RecordType [(l,t)]
desugarRecordType (RecordType fs)      = desugarMultiRecordType fs
desugarRecordType (And t1 t2)      = And (desugarRecordType t1) (desugarRecordType t2)
desugarRecordType t                = t
-- FIXME: incomplete cases



desugarMultiRecordType :: [(Label,Type)] -> Type
desugarMultiRecordType []         = panic "Src.desugarMultiRecordTy"
desugarMultiRecordType [(l,t)]    = RecordType [(l,t)]
desugarMultiRecordType ((l,t):fs) = RecordType [(l,t)] `And` desugarMultiRecordType fs

-- | Returns the record fields of a type. Note that a type does not have to be a
-- record by itself in order for it to have fields. (See the second example
-- below.)
-- Examples (in pseudo-code):
--   recordFields(String) = {}
--   recordFields(String&{name:String, age:Int}) = {"name" => String, "age" => Int}
recordFields :: Type -> Map.Map Label Type
recordFields (RecordType fs) =
  case intersectionBias of
    -- `Map.fromList` is right-biased.
    -- For example:
    --   ghci> Map.fromList [(1,"one"),(1,"yat")]
    --   fromList [(1,"yat")]
    LeftBiased  -> Map.fromList (reverse fs)
    RightBiased -> Map.fromList fs
recordFields (And t1 t2) =
  case intersectionBias of
    -- But `Map.union` is left-biased.
    -- For example:
    --   ghci> Map.fromList [(1,"one")] `Map.union` Map.fromList [(1,"yat")]
    --   fromList [(1,"one")]
    LeftBiased  -> recordFields t1 `Map.union` recordFields t2
    RightBiased -> recordFields t2 `Map.union` recordFields t1
recordFields _         = Map.empty

-- Free variable substitution

fsubstTT :: (Name, Type) -> Type -> Type
fsubstTT (x,r) (TVar a)
  | a == x                     = r
  | otherwise                  = TVar a
fsubstTT (_,_) (JClass c)      = JClass c
fsubstTT (x,r) (Fun t1 t2)     = Fun (fsubstTT (x,r) t1) (fsubstTT (x,r) t2)
fsubstTT (x,r) (TupleType ts)  = TupleType (map (fsubstTT (x,r)) ts)
fsubstTT (x,r) (Forall (a,c) t)
    | a == x || a `Set.member` freeTVars r = -- The freshness condition, crucial!
        let fresh = freshName a (freeTVars t `Set.union` freeTVars r)
        in Forall (fresh,c) (fsubstTT (x,r) (fsubstTT (a, TVar fresh) t))
    | otherwise                = Forall (a,c) (fsubstTT (x,r) t)
fsubstTT (_,_) Unit            = Unit
fsubstTT (x,r) (RecordType fs)     = RecordType (map (second (fsubstTT (x,r))) fs)
fsubstTT (x,r) (And t1 t2)     = And (fsubstTT (x,r) t1) (fsubstTT (x,r) t2)
fsubstTT (x,r) (OpAbs a t)
    | a == x || a `Set.member` freeTVars r = -- The freshness condition, crucial!
        let fresh = freshName a (freeTVars t `Set.union` freeTVars r)
        in OpAbs fresh (fsubstTT (x,r) (fsubstTT (a, TVar fresh) t))
    | otherwise                = OpAbs a (fsubstTT (x,r) t)
fsubstTT (x,r) (OpApp t1 t2)   = OpApp (fsubstTT (x,r) t1) (fsubstTT (x,r) t2)
fsubstTT (x,r) (Datatype n ts ns) = Datatype n (map (fsubstTT (x,r)) ts) ns

freshName :: Name -> Set.Set Name -> Name
freshName name existedNames = head $ dropWhile (`Set.member` existedNames) [name ++ show i | i <- [1 :: Int ..]]

freeTVars :: Type -> Set.Set Name
freeTVars (TVar x)     = Set.singleton x
freeTVars (JClass {})  = Set.empty
freeTVars Unit         = Set.empty
freeTVars (Fun t1 t2)  = freeTVars t1 `Set.union` freeTVars t2
freeTVars (Forall (a,Nothing) t) = Set.delete a (freeTVars t)
freeTVars (Forall (a,Just c) t) = freeTVars c `Set.union` Set.delete a (freeTVars t)
freeTVars (TupleType ts) = Set.unions (map freeTVars ts)
freeTVars (RecordType fs)  = Set.unions (map (\(_l,t) -> freeTVars t) fs)
freeTVars (And t1 t2)  = Set.union (freeTVars t1) (freeTVars t2)
freeTVars (OpAbs _ t)  = freeTVars t
freeTVars (OpApp t1 t2) = Set.union (freeTVars t1) (freeTVars t2)
freeTVars (Datatype _ ts _) = Set.unions (map freeTVars ts)

-- Pretty printers
instance Pretty Kind where
  pretty Star           = char '*'
  pretty (KArrow k1 k2) = parens (pretty k1 <+> text "=>" <+> pretty k2)


instance (Pretty id, Show id, Pretty ty, Show ty) => Pretty (ModuleBind id ty) where
  pretty (BindRec bs) = vcat (intersperse (text "and") (map pretty bs))
  pretty (BindNonRec bs) = pretty bs

instance (Pretty id, Show id, Pretty ty, Show ty) => Pretty (Module id ty) where
  pretty (Module imps bs) = text "module" <+> text "{" <>
                                              vcat (map pretty imps) <$>
                                              vcat (map pretty bs) <$> text "}"

instance (Pretty id) => Pretty (PoorMensImport id) where
    pretty (PoorMensImport id) = text "import" <+> pretty id

instance Pretty Type where
  pretty (TVar a)     = text a
  pretty (JClass "java.lang.Integer")   = text "Int"
  pretty (JClass "java.lang.String")    = text "String"
  pretty (JClass "java.lang.Boolean")   = text "Bool"
  pretty (JClass "java.lang.Character") = text "Char"
  pretty (JClass c)   = text c
  pretty Unit         = text "Unit"
  pretty (Fun t1 t2)  = parens $ pretty t1 <+> text "->" <+> pretty t2
  pretty (Forall a t) = parens $ forall <+> hsep (map prettyConstainedTyParam as) <> dot <+> pretty t' where (as, t') = groupForall (Forall a t)
  pretty (TupleType ts) = lparen <> hcat (intersperse comma (map pretty ts)) <> rparen
  pretty (And t1 t2)  = pretty t1 <> text "&" <> pretty t2
  pretty (RecordType fs)  = lbrace <> hcat (intersperse comma (map (\(l,t) -> text l <> colon <> pretty t) fs)) <> rbrace
  pretty (OpAbs x t)  = backslash <> text x <> dot <+> pretty t
  pretty (OpApp t1 t2) = parens (pretty t1 <+> pretty t2)
  pretty (Datatype n ts _) = hsep (text n : map pretty ts)

prettyConstainedTyParam :: (Name, Maybe Type) -> Doc
prettyConstainedTyParam (a, Nothing) = text a
prettyConstainedTyParam (a, Just t)  = parens (text a <+> char '*' <+> pretty t)

groupForall :: Type -> ([(Name, Maybe Type)], Type)
groupForall (Forall (a,c) t) = let (as, t') = groupForall t in ((a,c):as, t')
groupForall t            = ([], t)

-- Location can be ignored when pretty printing.
instance (Pretty a) => (Pretty (Located a)) where
  pretty (L _ x) = pretty x

instance (Show id, Pretty id, Show ty, Pretty ty) => Pretty (Expr id ty) where
  pretty (Var x) = pretty x
  pretty (Lit (Int n))     = integer n
  pretty (Lit (String n))  = string n
  pretty (Lit (Bool n))    = bool n
  pretty (Lit (Char n))    = char n
  pretty (Lit  UnitLit)    = unit
  pretty (BLam (a,_) e) = parens $ text "/\\" <> text a <> dot <+> pretty e -- TODO
  pretty (Lam (x,t) e) =
    parens $
      backslash <> parens (pretty x <+> colon <+> pretty t) <> dot <+>
      pretty e
  pretty (TApp e t) = parens $ pretty e <+> pretty t
  pretty (App e1 e2) = parens $ pretty e1 <+> pretty e2
  pretty (TupleCon es) = lparen <> (hcat . intersperse comma $ map pretty es) <> rparen
  pretty (TupleProj e i) = parens (pretty e) <> text "._" <> int i
  pretty (PrimOp e1 op e2) = parens $
                               parens (pretty e1) <+>
                               text (show op) <+>
                               -- text (P.prettyPrint op) <+>
                               parens (pretty e2)
  pretty (If e1 e2 e3) = parens $
                            text "if" <+> pretty e1 <+>
                            text "then" <+> pretty e2 <+>
                            text "else" <+> pretty e3
  pretty (LetIn recFlag bs e) =
    text "let" <+> pretty recFlag <+>
    encloseSep empty empty (softline <> text "and" <> space) (map pretty bs) <+>
    text "in" <+>
    pretty e
  pretty (LetOut recFlag bs e) =
    text "let" <+> pretty recFlag <+>
    encloseSep empty empty (softline <> text "and" <> space)
      (map (\(f1,t1,e1) -> text f1 <+> colon <+> pretty t1 <+> equals <+> pretty e1) bs) <+>
    text "in" <+>
    pretty e
  pretty (JNew c args)  = text "new" <+> text c <> tupled (map pretty args)
  pretty (JMethod e m args _) = case e of (Static c)     -> pretty c  <> dot <> text m <> tupled (map pretty args)
                                          (NonStatic e') -> pretty e' <> dot <> text m <> tupled (map pretty args)
  pretty (JField e f _) = case e of (Static c)     -> pretty c  <> dot <> text f
                                    (NonStatic e') -> pretty e' <> dot <> text f
  pretty (PolyList l)    = brackets . hcat . intersperse comma $ map pretty l
  pretty (Error _ str)  = text "error:" <+> pretty str
  pretty (Merge e1 e2)  = parens $ pretty e1 <+> text ",," <+> pretty e2
  pretty (RecordCon fs) = lbrace <> hcat (intersperse comma (map (\(l,t) -> text l <> equals <> pretty t) fs)) <> rbrace
  pretty (Data recFlag datatypes e ) =
    text "data" <+> pretty recFlag <+>
    vsep (map pretty datatypes) <$>
    pretty e

  pretty (Case e alts) = hang 2 (text "case" <+> pretty e <+> text "of" <$> text " " <+> intersperseBar (map pretty alts))
  pretty (CaseString e alts) = hang 2 (text "case" <+> pretty e <+> text "of" <$> text " " <+> intersperseBar (map pretty alts))
  pretty (ConstrOut c es) = parens $ hsep $ text (constrName c) : map pretty es
  pretty e = text (show e)

instance (Show id, Pretty id, Show ty, Pretty ty) => Pretty (Bind id ty) where
  pretty Bind{..} =
    pretty bindName <+>
    hsep (map pretty bindTyParams) <+>
    hsep (map (\(x,t) -> parens (pretty x <+> colon <+> pretty t)) bindParams) <+>
    case bindRhsTyAscription of { Nothing -> empty; Just t -> colon <+> pretty t } <+>
    equals <+>
    pretty bindRhs

instance Pretty RecFlag where
  pretty Rec    = text "rec"
  pretty NonRec = empty

instance Pretty Constructor where
    pretty (Constructor n ts) = hsep $ text n : map pretty ts

instance Pretty DataBind where
  pretty (DataBind n tvars cons) = hsep (map text $ n:tvars) <+> align (equals <+> intersperseBar (map pretty cons) <$$> semi)

instance (Show id, Pretty id, Show ty, Pretty ty) => Pretty (Alt id ty) where
    -- pretty (Default e) = text "_" <+> arrow <+> pretty e
    pretty (ConstrAlt p e2)    = pretty p <+> arrow <+> pretty e2

instance Pretty Pattern where
    pretty (PVar nam _)     = text nam
    pretty (PWildcard)      = text "_"
    pretty (PConstr ctr []) = text (constrName ctr)
    pretty (PConstr ctr ps) = text (constrName ctr) <+> hsep (map pretty2 ps)
      where pretty2 (PConstr ctr' [])  = text (constrName ctr')
            pretty2 (PConstr ctr' ps') = parens $ text (constrName ctr') <+> hsep (map pretty ps')
            pretty2 (PVar nam _)       = text nam
            pretty2 (PWildcard)        = text "_"

-- Utilities

wrap :: (b -> a -> a) -> [b] -> a -> a
wrap cons xs t = foldr cons t xs

-- Precedence of operators based on the table in:
-- http://en.wikipedia.org/wiki/Order_of_operations#Programming_languages
opPrec :: Num a => Operator -> a
opPrec (Arith J.Mult)     = 3
opPrec (Arith J.Div)      = 3
opPrec (Arith J.Rem)      = 3
opPrec (Arith J.Add)      = 4
opPrec (Arith J.Sub)      = 4
opPrec (Compare J.LThan)  = 6
opPrec (Compare J.GThan)  = 6
opPrec (Compare J.LThanE) = 6
opPrec (Compare J.GThanE) = 6
opPrec (Compare J.Equal)  = 7
opPrec (Compare J.NotEq)  = 7
opPrec (Logic J.CAnd)     = 11
opPrec (Logic J.COr)      = 12

-- utilities for pattern match

isWildcardOrVar :: Pattern -> Bool
isWildcardOrVar (PConstr _ _) = False
isWildcardOrVar     _         = True

---- return (appearing constructors, missing constructor)
constrInfo :: [Pattern] -> ([Constructor],[Name])
constrInfo patshead =
    if all isWildcardOrVar patshead then ([],[])
    else
        let (PConstr (Constructor _ types) _) = patshead !! fromJust (findIndex (not. isWildcardOrVar) patshead)
            (Datatype _ _ allcontructor') = last types
            allcontructor = Set.fromList allcontructor'
            appearconstructor' = nub [ ctr | PConstr ctr@(Constructor _ _ ) _ <- patshead ]
            appearconstructor = Set.fromList $ map constrName appearconstructor'
        in
            (appearconstructor', Set.toList $ Set.difference allcontructor appearconstructor)

---- utility for specialized matrix
extractorsubpattern :: Name -> Int -> Pattern -> [Pattern]
extractorsubpattern   _  num PWildcard = replicate num PWildcard
extractorsubpattern   _  num (PVar _ _) = replicate num PWildcard
extractorsubpattern name  _  (PConstr (Constructor name' _) subpattern)
    | name == name' = subpattern
    | otherwise     = []

centainPConstr :: Name -> Pattern -> Bool
centainPConstr name (PConstr (Constructor name' _) _) = name == name'
centainPConstr  _  _ = False

-- specialized matrix S(c, P)
--           pi1               |        S(c ,P)
--  c (r1,...,ra)              |     r1,...,ra,pi2,...pin
--  c' (r1,...,ra), c'/=c      |     no row
--  _                          |     _ ... _, pi2,...pin
specializedMatrix :: Constructor -> [[Pattern]] -> [[Pattern]]
specializedMatrix ctr pats =
    let (Constructor name types) = ctr
        num = length types - 1
    in  [ res ++ tail list1 | list1 <- pats,
                              let curPattern = head list1,
                              isWildcardOrVar curPattern || centainPConstr name curPattern,
                              let res = extractorsubpattern name num curPattern ]

-- default matrix D(P)
--           pi1               |        D(P)
--  c (r1,...,ra)              |     no row
--  _                          |     pi2,...pin
defaultMatrix :: [[Pattern]] -> [[Pattern]]
defaultMatrix pats =
    [tail list1 | list1 <- pats, isWildcardOrVar . head $ list1]


<|start_filename|>backend/BaseTransCFJava.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts, TypeOperators, MultiParamTypeClasses, ScopedTypeVariables #-}
{- |
Module      :  BaseTransCFJava
Description :  Basic translation of FCore to Java
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Tomas <<EMAIL>>
Stability   :  stable
Portability :  non-portable (MPTC)

This module implements the basic translation of FCore to Java. For
more information, please refer to the paper on wiki.
-}


module BaseTransCFJava where
-- translation that does not pre-initialize Closures that are ininitalised in apply() methods of other Closures
-- TODO: isolate all hardcoded strings to StringPrefixes (e.g. Fun)


import           Data.Char (toLower)
import           Data.List (zip4, elemIndex)
import qualified Language.Java.Syntax as J
import           Lens.Micro

import           ClosureF
import           Inheritance
import           JavaEDSL
import           MonadLib hiding (Alt)
import           Panic
import qualified Src as S
import           StringPrefixes

instance (:<) (Translate m) (Translate m) where
   up = id

type InitVars = [J.BlockStmt]

-- Closure F to Java

createCUB :: Maybe J.PackageDecl -> [J.TypeDecl] -> J.CompilationUnit
createCUB package compDef = cu
  where cu = J.CompilationUnit package [] compDef


initClass :: String -> String -> J.Exp -> J.BlockStmt
initClass className tempName expr =
  let ty = classTy className
  in localFinalVar ty (varDecl tempName (if ty == objClassTy
                                            then expr
                                            else cast ty expr))

type Var = Int -- Either normal variable or class name

type TransJavaExp = Either J.Name J.Literal -- either variable or special case: Lit

type TransType = ([J.BlockStmt], TransJavaExp, Type Int)

data Translate m =
  T {translateM :: Expr Int (Var,Type Int) -> m TransType
    ,translateScopeM :: EScope Int (Var,Type Int) -> Maybe (Int,Type Int) -> m ([J.BlockStmt],TransJavaExp,TScope Int)
    ,translateApply :: Bool -> m TransType -> m TransType -> m TransType
    ,translateIf :: m TransType -> m TransType -> m TransType -> m TransType
    ,translateLet :: TransType -> ((Var,Type Int) -> Expr Int (Var,Type Int)) -> m TransType
    ,translateScopeTyp :: Int -> Int -> [J.BlockStmt] -> EScope Int (Var,Type Int) -> m ([J.BlockStmt],TransJavaExp,TScope Int) -> String -> m ([J.BlockStmt],TScope Int)
    ,genApply :: J.Exp -> TScope Int -> String -> J.Type -> J.Type -> m [J.BlockStmt]
    ,genRes :: TScope Int -> [J.BlockStmt] -> m [J.BlockStmt]
    ,applyRetType :: Type Int -> m (Maybe J.Type)
    ,genClone :: m Bool
    ,transAlts :: TransJavaExp -> [Alt Int (Var,Type Int)] -> m TransType
    ,mapAlt :: J.Exp -> J.Name -> Alt Int (Var,Type Int) -> m (J.SwitchBlock,Type Int)
    ,translateDatabind :: DataBind Int -> m (J.BlockStmt,J.BlockStmt)
    ,translateCtr :: String -> Constructor Int -> Integer -> m [J.Decl]
    ,translateCtrParams :: String -> [Type Int] -> [J.Argument] -> m ([J.BlockStmt],TransJavaExp)
    ,withApply :: m Bool
    ,getPrefix :: m String
    ,javaType :: Type Int -> m J.Type
    ,chooseCastBox :: Type Int -> m (String -> J.Exp -> J.BlockStmt,J.Type)
    ,stackMainBody :: Type Int -> m [J.BlockStmt]
    ,genClosureVar :: Bool -> Int -> TransJavaExp -> m J.Exp
    ,transDefs :: Definition Int (Var,Type Int) -> m [J.BlockStmt]
    ,createWrap :: String -> Expr Int (Var,Type Int) -> m (J.CompilationUnit,Type Int)}

-- needed
getTupleClassName :: [a] -> String
getTupleClassName tuple =
  if lengthOfTuple > 50
     then panic "The length of tuple is too long (>50)!"
     else namespace ++ "tuples.Tuple" ++ show lengthOfTuple
  where lengthOfTuple = length tuple

getS3 :: MonadState Int m
      => Translate m
      -> J.Exp
      -> J.Exp
      -> TScope Int
      -> J.Type
      -> m ([J.BlockStmt],TransJavaExp)
getS3 this j1 j2 retTyp ctempCastTyp =
  do (n :: Int) <- get
     put (n+2)
     let f = localvarstr ++ show n
     let xf = localvarstr ++ show (n+1)
     let fexp = left . var $ f
     let fd = localVar ctempCastTyp (varDecl f j1)
     let fs = assignField (fieldAccExp fexp closureInput) j2
     (castBox,typ) <- chooseCastBox this (scope2ctyp retTyp)
     apply <- genApply this fexp retTyp xf typ ctempCastTyp
     let fout = fieldAccess fexp closureOutput
     res <- genRes this retTyp [castBox xf fout]
     let r = fd : fs : apply ++ res
     return (r, var xf)

genIfBody :: MonadState Int m
          => Translate m
          -> m TransType
          -> m TransType
          -> ([J.BlockStmt],TransJavaExp)
          -> Int
          -> m TransType
genIfBody this m2 m3 (s1,j1) n =
  do (s2,j2,t2) <- m2 {-translateM this e2-}
     (s3,j3,_) <- m3 {-translateM this e3-}
     let ifvarname = ifresultstr ++ show n
     aType <- javaType this t2
     let ifresdecl = localVar aType (varDeclNoInit ifvarname)
     let thenPart  = J.StmtBlock $ block (s2 ++ [bsAssign (name [ifvarname]) (unwrap j2)])
     let elsePart  = J.StmtBlock $ block (s3 ++ [bsAssign (name [ifvarname]) (unwrap j3)])
     let ifstmt    = bStmt $ J.IfThenElse (unwrap j1) thenPart elsePart

     return (s1 ++ [ifresdecl,ifstmt],var ifvarname ,t2) -- need to check t2 == t3

initializeRec this types binds = do
  (n :: Int) <- get
  let needed = length types
  put (n + 1 + needed)
  let mfuns xs = forM (binds xs) (translateM this)
  -- let (bindings :: [Var]) = [n + 1.. n + needed]
  let newvars = zip [n + 1 ..] types
  let finalFuns = mfuns newvars
  -- let appliedBody = body newvars
  rBinds <- liftM unzip3 finalFuns
  -- rBody <- translateM this appliedBody
  return (n, newvars, rBinds)


-- needed
assignVar :: Monad m => Translate m -> Type Int -> String -> J.Exp -> m J.BlockStmt
assignVar this t varId e = do aType <- javaType this t
                              return $ localFinalVar aType (varDecl varId e)


pairUp :: [Var] -> [(TransJavaExp, Type Int)] -> [(Var, Type Int)]
pairUp bindings vars = exchanged
  where z = bindings `zip` vars
        exchanged = map (\(a,(_,c)) -> (a,c)) z

-- Needed
getNewVarName :: MonadState Int m => Translate m -> m String
getNewVarName _ = do (n :: Int) <- get
                     put (n + 1)
                     return $ localvarstr ++ show n

isModule :: Expr t e -> (Maybe S.PackageName, Bool)
isModule (Module pname _) = (pname, True)
isModule _ = (Nothing, False)

trans :: (MonadState Int m, selfType :< Translate m) => Base selfType (Translate m)
trans self =
  let this = up self
  in T {translateM =
          \e ->
            case e of
{-
    (x1 : T1 -> x2) in ∆
    -------------------------- :: cj-var
    Γ |-  x1 : T1 ~> x2 in {}
-}
              -- TODO: propagate names
              Var _ (i,t) -> return ([],var (localvarstr ++ show i),t)
              Lit lit ->
                case lit of
                  (S.Int i)    -> return ([], Right $ J.Int i,     JClass "java.lang.Integer")
                  (S.UnitLit)  -> return ([], Right J.Null, Unit)
                  (S.String s) -> return ([], Right $ J.String s,  JClass "java.lang.String")
                  (S.Bool b)   -> return ([], Right $ J.Boolean b, JClass "java.lang.Boolean")
                  (S.Char c)   -> return ([], Right $ J.Char c,    JClass "java.lang.Character")
              PrimOp e1 op e2 ->
                do (s1,j1,_) <- translateM this e1
                   (s2,j2,_) <- translateM this e2
                   let j1' = unwrap j1
                   let j2' = unwrap j2
                   let (jexpr,typ) = case op of
                                       (S.Arith realOp) -> (J.BinOp j1' realOp j2',JClass "java.lang.Integer")
                                       (S.Compare realOp) -> (J.BinOp j1' realOp j2',JClass "java.lang.Boolean")
                                       (S.Logic realOp) -> (J.BinOp j1' realOp j2',JClass "java.lang.Boolean")
                   newVarName <- getNewVarName this
                   assignExpr <- assignVar this typ newVarName jexpr
                   return (s1 ++ s2 ++ [assignExpr],var newVarName,typ)
              If e1 e2 e3 ->
                translateIf this
                            (translateM this e1)
                            (translateM this e2)
                            (translateM this e3)
              Tuple tuple ->
                case tuple of
                  [t] ->
                    do (s1,j1,t1) <- translateM this t
                       return (s1,j1,TupleType [t1])
                  _ ->
                    do tuple' <- mapM (translateM this) tuple
                       let (statements,exprs,types) = (unzip3 tuple') & _1 %~ concat
                       newVarName <- getNewVarName this
                       let c = getTupleClassName tuple
                       let rhs = instCreat (classTyp c) (map unwrap exprs)
                       assignExpr <- assignVar this (JClass c) newVarName rhs
                       return (statements ++ [assignExpr],var newVarName,TupleType types)
              Proj index expr ->
                do ret@(statement,javaExpr,exprType) <- translateM this expr
                   case exprType of
                     TupleType [_] -> return ret
                     TupleType types ->
                       do newVarName <- getNewVarName this
                          let typ = types !! (index - 1)
                          aType <- javaType this typ
                          let rhs = cast aType (fieldAccess (unwrap javaExpr) ("_" ++ show index))
                          assignExpr <- assignVar this typ newVarName rhs
                          return (statement ++ [assignExpr] ,var newVarName ,typ)
                     _ ->
                       panic "BaseTransCFJava.trans: expected tuple type"
{-
    E : ∀α∆.T2 ~> J in S  ∆;T2 ⇓ T3
    -------------------------------- :: cj-tapp
    Γ |- E T1 : T3[T1/α] ~> J in S
-}
              TApp expr t ->
                do n <- get
                   put (n + 1) -- needed to distinguish different type variables
                   (s,je,Forall (Kind f)) <- translateM this expr
                   return (s,je,scope2ctyp (substScope n t (f n)))
{-
    Γ; ∆ |- E : T ~> J in S
    ------------------------------- :: cj-abs
    Γ |- λ∆ . E : ∀∆ . T ~> J in S
-}
              -- TODO: propagate names
              Lam _ se ->
                do (s,je,t) <- translateScopeM this se Nothing
                   return (s,je,Forall t)
              -- TODO: propagate names
              Fix _ _ t s ->
                do (n :: Int) <- get
                   put (n + 1)
                   (expr,je,t') <- translateScopeM this (s (n,t)) (Just (n,t)) -- weird!
                   return (expr,je,Forall t')
              -- TODO: propagate names
              Let _ expr body ->
                do (s1, j1, t1) <- translateM this expr
                   translateLet this (s1,j1,t1) body
              -- TODO: propagate names
              LetRec _ types xs body ->
                do (n, newvars, (bindStmts,bindExprs,tBinds)) <- initializeRec this types xs
                   (bodyStmts,bodyExpr,tBody) <- translateM this (body newvars)
                   bindtyps <- mapM (javaType this) tBinds
                   typ <- javaType this tBody

                   -- initialize declarations
                   let bindings = map fst newvars
                   let mDecls = map (\(x, btyp) -> memberDecl (fieldDecl btyp (varDeclNoInit (localvarstr ++ show x))))
                                                              (zip bindings bindtyps)

                   -- assign new created closures bindings to variables
                   let letClassName = letTransName ++ show n
                   let letVarName = localvarstr ++ show n
                   let assm = map (\(i,jz) -> bsAssign (name [localvarstr ++ show i]) jz)
                                  (bindings `zip` map unwrap bindExprs)
                   let stasm = concatMap (\(a,b) -> a ++ [b]) (bindStmts `zip` assm)

                   let letClass = localClass letClassName (classBody (mDecls ++ [J.InitDecl False (J.Block stasm)]))

                   -- after let class, some variable initialization
                   let letVarInit = localVar (classTy (letTransName ++ show n))
                                    (varDecl letVarName (instCreat (classTyp letClassName) []))
                   let mVarsInit = map (\(x, btyp) -> (localVar btyp (varDecl x (fieldAccess (varExp letVarName) x))))
                                       (zip (map ((localvarstr ++) . show) bindings) bindtyps)


                   return (letClass : letVarInit : mVarsInit ++ bodyStmts, bodyExpr, tBody)
{-
    Γ |- E1 : ∀(x:T2)∆.T1 ~> J1 in S1
    Γ |- E2 : T2 ~> J2 in S2
    ∆;T1 ⇓ T3     f,xf fresh
    ----------------------------------- :: cj-app
    Γ |- E1 E2 : T3 in S1⊎S2⊎S3
    (S3 := see translateApply)
-}
              App e1 e2 ->
                   translateApply this False
                                  (translateM this e1)
                                  (translateM this e2)

              -- Module
              Module _ defs -> do defStmts <- transDefs this defs
                                  return (defStmts, var tempvarstr, Unit)

              -- InstanceCreation [TypeArgument] ClassType [Argument] (Maybe ClassBody)
              JNew c args ->
                do args' <- mapM (translateM this) args
                   let (statements,exprs,types) = unzip3 args' & _1 %~ concat
                   let rhs =
                         J.InstanceCreation
                           (map (\y -> case y of
                                         -- JClass "char" -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Character", [])]
                                         JClass x -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident x, [])]
                                         -- CFInt -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Integer", [])]
                                         -- CFInteger -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Integer", [])]
                                         -- CFChar -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Character", [])]
                                         -- CFCharacter -> J.ActualType $ J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Character", [])]
                                         _ -> sorry "BaseTransCFJava.trans.JNew: no idea how to do")
                                types)
                           (J.ClassType [(J.Ident c,[])])
                           (map unwrap exprs)
                           Nothing
                   let typ = JClass c
                   newVarName <- getNewVarName this
                   assignExpr <- assignVar this typ newVarName rhs
                   return (statements ++
                           [assignExpr]
                          ,var newVarName
                          ,typ)
              Error ty str -> do
                   (stmt, oexpr, _) <- translateM this str
                   let J.ExpStmt errormsg = classMethodCall (stringExp "Error: ") "concat" [unwrap oexpr]
                   let erro = bStmt $ methodCall ["System","err","println"] [errormsg]
                   let exit = bStmt $ methodCall ["System", "exit"] [integerExp 0]
                   return (stmt ++ [erro, exit], Right J.Null, ty)
              JMethod c m args r ->
                do args' <- mapM (translateM this) args
                   let (statements,exprs,types) = unzip3 args' & _1 %~ concat
                   let exprs' = map unwrap exprs
                   let refTypes =
                         map (\y -> case y of
                                     JClass x -> J.ClassRefType $ J.ClassType [(J.Ident x, [])]
                                     -- CFInt -> J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Integer", [])]
                                     -- CFInteger -> J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Integer", [])]
                                     -- CFChar -> J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Character", [])]
                                     -- CFCharacter -> J.ClassRefType $ J.ClassType [(J.Ident "java.lang.Character", [])]
                                     Datatype x _ _ -> J.ClassRefType $ J.ClassType [(J.Ident x, [])]
                                     _ -> sorry "BaseTransCFJava.trans.JMethod: no idea how to do")
                             types
                   (classStatement,rhs) <- case c of
                                             Right ce ->
                                               do (classS,classE,_) <- translateM this ce
                                                  return (classS ,J.MethodInv $ J.PrimaryMethodCall (unwrap classE) refTypes (J.Ident m) exprs')
                                             Left cn ->
                                               return ([] ,J.MethodInv $ J.TypeMethodCall (J.Name [J.Ident cn]) refTypes (J.Ident m) exprs')
                   if r /= "java.lang.Void"
                      then do let typ = JClass r
                              newVarName <- getNewVarName this
                              assignExpr <- assignVar this typ newVarName rhs
                              return (statements ++ classStatement ++ [assignExpr] ,var newVarName ,typ)
                      else return (statements ++ classStatement ++ [J.BlockStmt $ J.ExpStmt rhs], Right J.Null, Unit)
              JField c fName r ->
                do (classStatement,classExpr,_) <- case c of
                                                     Right ce ->
                                                       translateM this ce
                                                     Left cn ->
                                                       return ([],Left $ J.Name [J.Ident cn] ,undefined)
                   newVarName <- getNewVarName this
                   aType <- javaType this r
                   let rhs = J.Cast aType $ J.FieldAccess $ J.PrimaryFieldAccess (unwrap classExpr) (J.Ident fName)
                       assignExpr = localFinalVar aType $ varDecl newVarName rhs
                   return (classStatement ++ [assignExpr],var newVarName,r)
              SeqExprs es ->
                do es' <- mapM (translateM this) es
                   let (_,lastExp,lastType) = last es'
                   let statements = concatMap (\(x,_,_) -> x) es'
                   return (statements,lastExp,lastType)
              FVar _ -> sorry "BaseTransCFJava.trans.FVar: no idea how to do"
              ConstrOut (Constructor ctrName' ctrParams) es -> do
                   newVar <- getNewVarName this
                   let realType = last ctrParams
                   let getdt ty = case ty of Kind f -> getdt (f 0)
                                             Type _ f -> getdt (f ())
                                             Body (Datatype nam _ _) -> nam
                                             _ -> sorry "ConstrOut.gentdt: no idea how to do"
                   let nam = case realType of Datatype nam' _ _ -> nam'
                                              Forall t -> getdt t
                                              _ -> sorry "ConstrOut.nam: no idea how to do"
                   let ctrName = nam ++ ctrName'
                   case realType of
                       Datatype{} | null es -> do
                          let inst = localVar (classTy nam) (varDecl newVar $ methodCallExp [map toLower nam,ctrName] [])
                          return ([inst], var newVar, realType)
                       _ -> do
                          let st1 = localVar closureType (varDecl newVar $ methodCallExp [map toLower nam,ctrName] [])
                          let functiontype = case realType of
                                Datatype{} -> Forall $ foldr (\a b -> Type a (\()->b)) (Body realType) (init ctrParams)
                                Forall ts -> Forall $ foldr (\a b -> Type a (\()->b)) ts (init ctrParams)
                                _ -> sorry "ConstrOut.functiontype: no idea how to do"
                          foldl (translateApply this False)
                                (return ([st1], var newVar, functiontype))
                                (map (translateM this) es)
              Case scrut alts ->
                do (scrutStmts, scrutExpr, _) <- translateM this scrut
                   (altsStmts, varName, typ) <- transAlts this scrutExpr alts
                   return (scrutStmts ++ altsStmts, varName, typ)
              Data recflag databinds expr -> do
                (databindclass, databindproxy) <- mapAndUnzipM (translateDatabind this) databinds
                (s', e', t') <- translateM this expr
                case recflag of
                    S.NonRec -> return (databindclass ++ databindproxy ++ s', e', t')
                    S.Rec -> do
                        (n::Int) <- get
                        put (n+2)
                        typ <- javaType this t'
                        let datatypeclass =
                             [localClass ("Datatype" ++ show n)
                                         (classBody ( memberDecl (fieldDecl objClassTy (varDeclNoInit tempvarstr)) :
                                                      map localToMember databindclass ++
                                                      [J.InitDecl False (block $ databindproxy ++ s' ++ [bsAssign (name [tempvarstr]) (unwrap e')])]
                                                    ))
                             ,localVar (classTy ("Datatype" ++ show n))
                                       (varDecl (localvarstr ++ show n)
                                                (instCreat (classTyp ("Datatype" ++ show n)) []))
                             ,localFinalVar typ (varDecl (localvarstr ++ show (n + 1))
                                                         (cast typ (J.ExpName (name [localvarstr ++ show n, tempvarstr]))))]
                        return (datatypeclass,var (localvarstr ++ show (n + 1)),t')
        ,translateScopeM =
          \e m ->
            case e of
{-
    Γ |- E : T ~> J in S
    --------------------------- :: cjd-empty
    Γ;empty |- E : T ~> J in S
-}
              Body t ->
                do (s,je,t1) <- translateM this t
                   return (s,je,Body t1)

{-
    Γα;∆ ⊢ E : T ~> J in S
    ----------------------- :: cjd-bind2
    Γ;α∆ ⊢ E : T ~> J in S
-}
              Kind f ->
                do n <- get
                   put (n + 1) -- needed to distingush type variable
                   (s,je,t1) <- translateScopeM this (f n) m
                   return (s,je,Kind (\a -> substScope n (TVar a) t1))

{-
    Γ(y : T1 -> x2);∆ |- E : T ~> J in S
    FC, x1, x2, f fresh
    ------------------------------------- :: cjd-bind1
    Γ;(y : T1)∆ |- E : T ~> f in S'
    S' := (cvar)
-}
              Type t g ->
                do n <- get
                   let (x1,x2) = maybe (n + 1,n + 2) (\(i,_) -> (i,n+1)) m -- decide whether we have found the fixpoint closure or not
                   put (x2 + 1)
                   let nextInClosure = g (x2,t)

                   typT1 <- javaType this t
                   let flag = typT1 == objClassTy
                   let accessField = fieldAccess (left $ var (localvarstr ++ show x1)) closureInput
                   let xf = localFinalVar typT1 (varDecl (localvarstr ++ show x2)
                                                         (if flag
                                                             then accessField
                                                             else cast typT1 accessField))
                   closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
                   (cvar,t1) <- translateScopeTyp this x1 n [xf] nextInClosure (translateScopeM this nextInClosure Nothing) closureClass

                   let fstmt = [localVar closureType (varDecl (localvarstr ++ show n) (funInstCreate n))]

                   return (cvar ++ fstmt,var (localvarstr ++ show n),Type t (const t1))
       ,translateApply =
          \flag m1 m2 ->
            do (s1, j1',Forall (Type _ g)) <- m1
               (s2,j2,_) <- m2
               let retTyp = g ()
               j1 <- genClosureVar this flag (getArity retTyp) j1'
               (s3,nje3) <- getS3 this j1 (unwrap j2) retTyp closureType
               return (s2 ++ s1 ++ s3,nje3,scope2ctyp retTyp)
       ,translateIf =
          \m1 m2 m3 ->
            do n <- get
               put (n + 1)
               (s1,j1,_) <- m1 {- translateM this e1 -}
               genIfBody this m2 m3 (s1, j1) n
       ,translateLet =
            \(s1,j1,t1) body ->
             do (n :: Int) <- get
                put (n + 1)
                (s2, j2, t2) <- translateM this (body (n,t1))
                let x = localvarstr ++ show n
                jt1 <- javaType this t1
                let xDecl = localVar jt1 (varDecl x $ unwrap j1)
                return (s1 ++ [xDecl] ++ s2, j2, t2)
       ,translateDatabind =
            \(DataBind nam params ctrs) ->
                do n <- get
                   put (length params + n)
                   let tag = memberDecl $ finalFieldDecl intTy (varDeclNoInit datatypetag)
                       classctr = memberDecl $ constructorDecl nam [paramDecl intTy datatypetag] Nothing [initField datatypetag]
                   ctrs' <-  zipWithM (translateCtr this nam) (ctrs [n..length params +n-1]) [1..]
                   let classdef = localClass nam (classBody ([tag, classctr] ++ concat ctrs'))
                       proxy = localVar (classTy nam) (varDecl (map toLower nam) (instCreat (classTyp nam) [integerExp 0]) )
                   return (classdef,proxy)
       ,translateCtr =
            \nam (Constructor ctrname' types') tagnum ->
               case types' of
                 [_] -> do
                          let ctrname = nam ++ ctrname'
                              fielddecl = memberDecl $ fieldDecl (classTy nam) (varDeclNoInit ctrname )
                              singleton = bStmt $ ifthen (eq (varExp ctrname) nullExp)
                                                          (assignE (name [ctrname]) (instCreat (classTyp nam) [integerExp tagnum]))
                              methoddecl = memberDecl $ methodDecl [] (Just $ classTy nam) ctrname []
                                                        (Just $ block [singleton, returnExpS $ varExp ctrname])
                          return [fielddecl, methoddecl]
                 _ -> do
                         let types = init types'
                         javaty <- mapM (javaType this) types
                         let ctrname = nam ++ ctrname'
                             fields = map ((fieldtag ++ ) . show) [1..length types]
                             fieldsdec = map memberDecl $ zipWith  fieldDecl javaty (map varDeclNoInit fields)
                             ctrdecl = memberDecl $ constructorDecl ctrname (zipWith paramDecl javaty fields)
                                                    (Just $ J.SuperInvoke [] [integerExp tagnum])
                                                    (map initField fields)
                             ctrclass = memberDecl $ memberClassDecl ctrname nam (classBody ( fieldsdec ++ [ctrdecl] ))

                         (stmts, oexpr) <- translateCtrParams this ctrname types []
                         let methodbody = Just . block $ stmts ++ [returnExpS (unwrap oexpr)]
                         let methoddecl = memberDecl $ methodDecl [] (Just closureType) ctrname [] methodbody
                         return [ctrclass, methoddecl]
       ,translateCtrParams =
           \classnam types params ->
             case types of
                [] -> do
                    newVarName <- getNewVarName this
                    return ([localFinalVar (classTy classnam) $ varDecl newVarName $ instCreat (classTyp classnam) params], var newVarName)
                hd:tl -> do
                    n <- get
                    put (n+3)
                    typ <- javaType this hd
                    (stmt, oexpr) <- translateCtrParams this classnam tl (params++[varExp (localvarstr ++ show (n+2))])
                    let accessField = fieldAccess (left $ var (localvarstr ++ show (n+1))) closureInput
                    let initVar = localFinalVar typ (varDecl (localvarstr ++ show (n+2))
                                                             (if typ == objClassTy then accessField else cast typ accessField))
                    let classbody = closureBodyGen [memberDecl $ fieldDecl closureType (varDecl (localvarstr ++ show (n+1)) J.This)]
                                                   (initVar:stmt ++ [bsAssign (name [closureOutput]) (unwrap oexpr)])
                                                   n
                                                   False
                                                   closureType
                    let innerclassdef = localClassDecl (closureTransName ++ show n) ifoClass classbody
                    let funInst = localVar closureType (varDecl (localvarstr ++ show n) (funInstCreate n))
                    return ([innerclassdef, funInst], var (localvarstr ++ show n))
       ,transAlts =
           \scrut alts -> do
             let tagaccess = fieldAccess (unwrap scrut) datatypetag --tag access, to be switched
             newVar <- getNewVarName this --record result
             blocks <- mapM (mapAlt this (unwrap scrut) (name [newVar])) alts -- all the blocks
             let (blocks', type') = unzip blocks
             jtype <- javaType this $ head type'
             let newvardecl = localVar jtype $ varDecl newVar nullExp
                 switchstmt = bStmt $ switchStmt tagaccess blocks'
             return ([newvardecl, switchstmt], var newVar, head type')
       ,mapAlt =
           \scrut resultName alt ->
               case alt of
                   Default e1 -> do
                       (altstmt, alte, altt) <- translateM this e1
                       let result = bsAssign resultName (unwrap alte)
                       return (switchBlock Nothing $ altstmt ++ [result], altt)
                   ConstrAlt (Constructor ctrname types) e1 -> do
                       let (Datatype _ _ ctrnames) = last types
                           Just label = elemIndex ctrname ctrnames
                       (altstmt, alte, altt) <- translateM this e1
                       let result = bsAssign resultName (unwrap alte)
                       return (switchBlock
                                  (Just (integerExp $ fromIntegral label + 1))
                                  (altstmt ++ [result]),
                               altt)
       ,translateScopeTyp =
          \x1 f initVars _ otherStmts closureClass ->
            do b <- genClone this
               (ostmts,oexpr,t1) <- otherStmts
               let fc = f
               return ([localClassDecl (closureTransName ++ show fc)
                                       closureClass
                                       (closureBodyGen [memberDecl $ fieldDecl (classTy closureClass)
                                                                               (varDecl (localvarstr ++ show x1) J.This)]
                                                       (initVars ++ ostmts ++ [bsAssign (name [closureOutput]) (unwrap oexpr)])
                                                       fc
                                                       b
                                                       (classTy closureClass))]
                      ,t1)
       ,genApply = \f _ _ _ _ -> return [bStmt $ applyMethodCall f]
       ,genRes = const return
       ,genClosureVar = \_ _ j1 ->  return (unwrap j1)
       ,javaType = \typ -> case typ of
                             (JClass c) -> return $ classTy c
                             (Forall (Kind f)) -> case f 0 of -- TODO: could be a bug
                                                   Body typ' -> javaType this typ'
                                                   _ -> do closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
                                                           return (classTy closureClass)
                             (Forall _) -> do closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
                                              return (classTy closureClass)
                             (TupleType tuple) -> case tuple of
                                                    [t] -> javaType this t
                                                    _ -> return $ classTy $ getTupleClassName tuple
                             -- CFInt -> return $ classTy "java.lang.Integer"
                             -- CFInteger -> return $ classTy "java.lang.Integer"
                             -- CFChar -> return $ classTy "java.lang.Character"
                             -- CFCharacter -> return $ classTy "java.lang.Character"
                             (ListType _) -> return $ classTy (namespace ++ "FunctionalList")
                             (Datatype nam _ _) -> return $ classTy nam
                             _ -> return objClassTy
       ,chooseCastBox = \typ -> case typ of
                                  (JClass c) -> return (initClass c, classTy c)
                                  -- CFInt -> return (initClass "java.lang.Integer", classTy "java.lang.Integer")
                                  -- CFInteger -> return (initClass "java.lang.Integer", classTy "java.lang.Integer")
                                  -- CFChar -> return (initClass "java.lang.Integer", classTy "java.lang.Character")
                                  -- CFCharacter -> return (initClass "java.lang.Integer", classTy "java.lang.Character")
                                  (Forall _) -> do closureClass <- liftM2 (++) (getPrefix this) (return "Closure")
                                                   return (initClass closureClass, classTy closureClass)
                                  (TupleType tuple) -> case tuple of
                                                         [t] -> chooseCastBox this t
                                                         _ -> do let tupleClassName = getTupleClassName tuple
                                                                 return (initClass tupleClassName, classTy tupleClassName)
                                  (ListType _) -> return (initClass (namespace ++ "FunctionalList"), classTy (namespace ++ "FunctionalList"))
                                  (Datatype nam _ _) -> return (initClass nam, classTy nam)
                                  _ -> return (initClass "Object", objClassTy)
       ,getPrefix = return namespace
       ,genClone = return False -- do not generate clone method
       ,withApply = return True
       ,stackMainBody = \_ -> return []
       ,applyRetType = \t -> (case t of
                               JClass "java.lang.Integer" -> return $ Just $ J.PrimType J.IntT
                               JClass "java.lang.Boolean" -> return $ Just $ J.PrimType J.BooleanT
                               -- CFInt -> return $ Just $ J.PrimType J.IntT
                               -- CFChar -> return $ Just $ J.PrimType J.CharT
                               _ -> return $ Just objClassTy)
       ,createWrap =
          \nam expr ->
              do (bs,e,t) <- translateM this expr
                 returnType <- applyRetType this t
                 let (package, flag) = isModule expr
                 let javaCode = if flag
                                then wrapperClass flag nam bs returnType moduleMainBody
                                else let returnStmt = [bStmt $ J.Return $ Just (unwrap e)]
                                     in wrapperClass flag nam (bs ++ returnStmt) returnType mainBody
                 return (maybe (createCUB Nothing [javaCode])
                               (\pname -> createCUB  (Just (J.PackageDecl (name [pname]))) [javaCode]) package, t)

       ,transDefs =
         \ defs -> case defs of
                     Def fname srcTyp expr otherDef ->
                       do (bs,e,t) <- translateM this expr
                          (n :: Int) <- get
                          put (n + 1)
                          otherDefStmts <- transDefs this (otherDef (n, t))
                          let x = localvarstr ++ show n
                          typ <- javaType this t
                          let anno = normalAnno fname x (show srcTyp)
                          let xDecl = localVarWithAnno anno typ (varDecl x $ unwrap e)
                          return (bs ++ [xDecl] ++ otherDefStmts)
                     DefRec names types exprs body -> do
                       (n, newvars, (bindStmts, bindExprs, tBinds)) <- initializeRec this (map snd types) exprs
                       bodyStmts <- transDefs this (body newvars)
                       bindtyps <- mapM (javaType this) tBinds
                       let srcTypes = map fst types

                       -- create annotations for each variable
                       let varnums = map ((localvarstr ++) . show . fst) newvars
                       let annos = map (\(fname, x, srcTyp) -> normalAnno fname x (show srcTyp)) (zip3 names varnums srcTypes)

                       -- assign new created closures bindings to variables
                       let assm = map (\(anno,i,typ,jz) -> localVarWithAnno anno typ (varDecl i jz))
                                      (zip4 annos varnums bindtyps (map unwrap bindExprs))
                       return (concatMap (\(a,b) -> a ++ [b]) (bindStmts `zip` assm) ++ bodyStmts)
                     Null -> return []

       }


<|start_filename|>runtime/src/f2j/unbox/Next.java<|end_filename|>
package f2j.unbox;

public class Next
{
  public static Closure next = null;
}


<|start_filename|>frontend/PrettyUtils.hs<|end_filename|>
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{- |
Module      :  PrettyUtils
Description :  Utilities for pretty printing.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module PrettyUtils where

import Data.Char (ord, chr)
import Data.List (intersperse)
import Text.PrettyPrint.ANSI.Leijen

-- class Outputable a where
--   pretty :: a -> Doc
--   pretty = prettyPrec basePrec

--   prettyPrec   :: Prec -> a -> Doc
--   prettyPrec _ = PrettyUtils.pretty

arrow     = text "->"
forall    = text "forall"
ampersand = text "&"
lambda    = text "\\"
biglambda = text "/\\"
dcomma    = text ",,"
unit      = text "()"
bar       = text "|"
evalTo    = text "==>"
mu        = text "mu"
castup    = text "cast↑"
castdown  = text "cast↓"


bquote :: Doc
bquote = char '`'

bquotes :: Doc -> Doc
bquotes = enclose bquote bquote

commas :: [Doc] -> Doc
commas docs = hcat $ intersperse (comma <> space) docs

-- | Prettify a document as code.
code :: Doc -> Doc
code doc = char '‘' <> doc <> char '’'


type PrecLevel = Int
data PrecDelta = PrecMinus | PrecPlus
type Prec      = (PrecLevel, PrecDelta)

basePrec :: Prec
basePrec = (0, PrecMinus)

parensIf :: Prec -> PrecLevel -> Doc -> Doc
parensIf (envLevel, envDelta) myLevel doc
  | envLevel > myLevel  = parens doc
  | envLevel == myLevel =
    case envDelta of
      PrecPlus  -> parens doc
      PrecMinus -> doc
  | otherwise           = doc

prettyTVar, prettyVar :: Int -> Doc
prettyTVar = prettyVarFrom 'A'
prettyVar  = prettyVarFrom 'a'

prettyNVar :: String -> Int -> Doc
prettyNVar n j = prettyVar j <> (if n == "_" then empty else char '/' <> text n)

prettyVarFrom :: Char -> Int -> Doc
prettyVarFrom c n
  | n < 26    = text [chr (ord c + n)]
  | otherwise = text (c : show n)

intersperseBar :: [Doc] -> Doc
intersperseBar = foldl1 (\acc x -> acc <$$> bar <+> x)

prependNot :: Doc -> Doc
prependNot d = text "not" <+> d

combineWithAnd :: Doc -> Doc -> Doc
combineWithAnd d1 d2 = d1 <+> text "&&" <+> d2


<|start_filename|>frontend/JavaUtils.hs<|end_filename|>
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{- |
Module      :  JavaUtils
Description :  Utilities for compiling and running Java from Haskell, etc.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module JavaUtils
  ( getRuntimeJarPath
  , getClassPath
  , compileJava, runJava
  , inferOutputPath, inferClassName
  , ClassName, MethodName, FieldName
  , ModuleName
  ) where

import StringUtils (capitalize)

import Paths_fcore
import System.Directory.Extra (withCurrentDirectory)
import System.FilePath (takeDirectory, takeFileName, takeBaseName, (</>), (<.>), dropExtension, searchPathSeparator)
import System.Process.Extra (system_)


type ClassName  = String
type MethodName = String
type FieldName  = String
type ModuleName = String

getRuntimeJarPath :: IO FilePath
getRuntimeJarPath = getDataFileName "runtime/runtime.jar"

getClassPath :: IO FilePath
getClassPath = do r <- getRuntimeJarPath
                  return $ r ++ [searchPathSeparator] ++ "."

-- Given the path to the source file,
-- infer the output path for the corresponding Java source.
-- "tests/pinepine/even_odd.sf" => "tests/pinepine/Even_odd.java"
inferOutputPath :: FilePath -> FilePath
inferOutputPath source_path =
  let fileName = (dropExtension . takeFileName $ source_path) ++ "$" -- avoid name clash
  in takeDirectory source_path </>
     capitalize fileName <.> "java"

inferClassName :: FilePath -> String
inferClassName outputPath = capitalize $ takeBaseName outputPath

compileJava :: FilePath -> IO ()
compileJava srcPath
  = do cp <- getClassPath
       system_ ("javac -cp " ++ cp ++ " " ++ srcPath)

runJava :: FilePath -> IO ()
runJava srcPath = do
  withCurrentDirectory (takeDirectory srcPath) $ do
    cp <- getClassPath
    system_ $ "java -cp " ++ cp ++ " " ++ takeBaseName srcPath
    system_ "rm *.class"


<|start_filename|>frontend/StringPrefixes.hs<|end_filename|>
module StringPrefixes where

namespace :: String
namespace = "f2j."

-- field and closures

ifoClass :: String
ifoClass = namespace ++ "Closure"

closureClass = namespace ++ "Closure"

typeHouse :: String
typeHouse = namespace ++ "TypeHouse"

typeField :: String
typeField = "typeOf"

closureTransName :: String
closureTransName = "F"

letTransName :: String
letTransName = "L"

localvarstr :: String
localvarstr = "x"

ifresultstr :: String
ifresultstr = "ifres"

-- temporary vars
tempvarstr :: String
tempvarstr = "temp"

-- Closure input field
closureInput :: String
closureInput = "arg"

-- Closure out field
closureOutput :: String
closureOutput = "res"

-- Datatype tag
datatypetag :: String
datatypetag = "tag"

fieldtag :: String
fieldtag = "field"

-- type annotation
annoName = namespace ++ "ModuleFunction"
annoSrcName = "name"
annoGenName = "gname"
annoSig = "signature"


<|start_filename|>frontend/Mixin.hs<|end_filename|>
{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall #-}

module Mixin where

import Prelude hiding (log)

class a <: b where
  up :: a -> b

instance (t1 <: t2) => (t -> t1) <: (t -> t2) where
  up f = up . f

instance (t1 <: t2) => (t2 -> t) <: (t1 -> t) where
  up f = f . up

type Class t   = t -> t
type Mixin s t = s -> t -> t

new :: Class a -> a
new f = let r = f r in r

with :: (t <: s) => Class s -> Mixin s t -> Class t
klass `with` mixin = \this -> mixin (klass (up this)) this

-- The below provides an example.

fib' :: Class (Int -> Int)
fib' _    1 = 1
fib' _    2 = 1
fib' this n = this (n-1) + this (n-2)

instance (Int, String) <: Int where
  up = fst

logging :: Mixin (Int -> Int) (Int -> (Int, String))
logging super _    1 = (super 1, "1")
logging super _    2 = (super 2, "2 1")
logging super this n = (super n, show n ++ " " ++ log1 ++ " " ++ log2)
  where
    (_, log1) = this (n-1)
    (_, log2) = this (n-2)

fibWithLogging :: Int -> (Int, String)
fibWithLogging = new (fib' `with` logging)


<|start_filename|>backend/ClosureF.hs<|end_filename|>
{-# Language RankNTypes, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{- |
Module      :  ClosureF
Description :   Abstract syntax and pretty printer for ClosureF.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Tomas <<EMAIL>>
Stability   :  stable
Portability :  non-portable (MPTC)

-}
module ClosureF where

import qualified Core as C
import           JavaUtils
import           Panic
import           PrettyUtils
import qualified Src as S
import           StringPrefixes

import           Control.Arrow (second)
import           Data.List (intersperse)
import qualified Language.Java.Pretty (prettyPrint)
import           Prelude hiding ((<$>))
import           Text.PrettyPrint.ANSI.Leijen

-- Closure F syntax

data Scope b t e =
      Body b
    | Kind (t -> Scope b t e)
    | Type (Type t) (e -> Scope b t e)

type TScope t = Scope (Type t) t ()

type EScope t e = Scope (Expr t e) t e

data Type t =
      TVar t
    | Forall (TScope t)
    | JClass ClassName
    | Unit
    | CFInt
    | CFInteger
    | CFChar
    | CFCharacter
    | TupleType [Type t]
    | ListType (Type t)
    | Datatype S.Name [Type t] [S.Name]

data Definition t e = Def S.Name S.Type (Expr t e) (e -> Definition t e)
                    | DefRec [S.Name] [(S.Type, Type t)] ([e] -> [Expr t e]) ([e] -> Definition t e)
                    | Null

data Expr t e =
     Var S.Name e
   | FVar Int
   | Lam S.Name (EScope t e)
   | App (Expr t e) (Expr t e)
   | TApp (Expr t e) (Type t)
   | PrimOp (Expr t e) S.Operator (Expr t e)
   | Lit S.Lit
   | If (Expr t e) (Expr t e) (Expr t e)
   | Tuple [Expr t e]
   | Proj Int (Expr t e)
   | Let S.Name (Expr t e) (e -> Expr t e)
   -- fixpoints
   | LetRec [S.Name] [Type t] ([e] -> [Expr t e]) ([e] -> Expr t e)
   | Fix S.Name S.Name (Type t) (e -> EScope t e)
   -- Module
   | Module (Maybe S.PackageName) (Definition t e)
   -- Java
   | JNew ClassName [Expr t e]
   | JMethod (Either ClassName (Expr t e)) MethodName [Expr t e] ClassName
   | JField  (Either ClassName (Expr t e)) FieldName (Type t)
   | SeqExprs [Expr t e]
   | Data S.RecFlag [DataBind t] (Expr t e)
   | ConstrOut (Constructor t) [Expr t e]
   | Case (Expr t e) [Alt t e]
   | Error (Type t) (Expr t e)

data DataBind t = DataBind S.Name [S.Name] ([t] -> [Constructor t])
data Constructor t = Constructor {constrName :: S.Name, constrParams :: [Type t]}
data Alt t e = ConstrAlt (Constructor t) (Expr t e)
             | Default (Expr t e)

-- System F to Closure F

ftyp2scope :: C.Type t -> TScope t
ftyp2scope (C.Forall _ f)   = Kind (ftyp2scope . f)
ftyp2scope (C.Fun t1 t2)  = Type (ftyp2ctyp t1) (\_ -> ftyp2scope t2)
ftyp2scope t             = Body (ftyp2ctyp t)
-- ftyp2scope PFInt         = Body CInt
-- ftyp2scope (FTVar x)     = Body (CTVar x)

{-
ftyp2ctyp2 :: C.Type Int -> [t] -> Type t
ftyp2ctyp2 = sorry "ClosureF.ftyp2ctyp2"
-}

ftyp2ctyp :: C.Type t -> Type t
ftyp2ctyp (C.TVar _ x)                     = TVar x
-- ftyp2ctyp (C.JClass "java.lang.Integer") = CFInt
ftyp2ctyp (C.JClass "java.lang.Integer") = JClass "java.lang.Integer"
-- ftyp2ctyp (C.JClass "java.lang.Character") = CFChar
ftyp2ctyp (C.JClass "java.lang.Character") = JClass "java.lang.Character"
ftyp2ctyp (C.JClass c)                   = JClass c
ftyp2ctyp (C.Product ts)                 = TupleType (map ftyp2ctyp ts)
ftyp2ctyp (C.Unit)                       = Unit
ftyp2ctyp (C.Datatype name params ctrnames ) = Datatype ('$':name) (map ftyp2ctyp params) (map ('$':)ctrnames)
ftyp2ctyp t                              = Forall (ftyp2scope t)

{-
fexp2cexp2 :: C.Expr Int (Int,F.Type Int) -> [t] -> [e] -> Expr t e
fexp2cexp2 (C.Var _ t) tenv env = CVar (env !! fst t)
fexp2cexp2 e tenv env = CLam (groupLambda2 e tenv env)
-}

{-
fexp2cexp2 :: C.Expr t (e, Type t) -> (Expr t e, Type t)
fexp2cexp2 (C.Var _ (x,t))      = (CVar x,t)
fexp2cexp2 (C.App e1 e2)        =
   let (c1,CForall (Typ t g))  = fexp2cexp2 e1
       (c2,t2)                 = fexp2cexp2 e2
   in (CApp c1 c2, undefined (g ()))
fexp2cexp2 (C.TApp e t)   =
   let (c1,t1) = fexp2cexp e
CTApp (fexp2cexp e) (ftyp2ctyp t)
-}


fdef2cdef :: C.Definition t e -> Definition t e
fdef2cdef (C.Def fname typ e def) = Def fname typ (fexp2cexp e) (fdef2cdef . def)
fdef2cdef (C.DefRec names types exprs def) =
          DefRec names (map (second ftyp2ctyp) types) (map fexp2cexp . exprs) (fdef2cdef . def)
fdef2cdef C.Null = Null

fexp2cexp :: C.Expr t e -> Expr t e
fexp2cexp (C.Var rid x)                = Var rid x
fexp2cexp (C.App e1 e2)              = App (fexp2cexp e1) (fexp2cexp e2)
fexp2cexp (C.TApp e t)               = TApp (fexp2cexp e) (ftyp2ctyp t)
fexp2cexp (C.PrimOp e1 op e2)        = PrimOp (fexp2cexp e1) op (fexp2cexp e2)
fexp2cexp (C.Lit S.UnitLit) = Lit S.UnitLit
fexp2cexp (C.Lit e)         = Lit e
fexp2cexp (C.If e1 e2 e3)            = If (fexp2cexp e1) (fexp2cexp e2) (fexp2cexp e3)
fexp2cexp (C.Tuple tuple)            = Tuple (map fexp2cexp tuple)
fexp2cexp (C.Proj i e)               = Proj i (fexp2cexp e)
fexp2cexp (C.Let n bind body)        = Let n (fexp2cexp bind) (fexp2cexp . body)
fexp2cexp (C.LetRec n ts f g) = LetRec n (map ftyp2ctyp ts) (map fexp2cexp . f) (fexp2cexp . g)
fexp2cexp (C.Fix n1 n2 f t1 t2) =
  let  g e = groupLambda (C.Lam "_" t1 (f e)) -- is this right???? (BUG)
  in   Fix n1 n2 (Forall (adjust (C.Fun t1 t2) (g undefined))) g
fexp2cexp (C.Module pname defs) = Module pname (fdef2cdef defs)
fexp2cexp (C.JNew cName args)     = JNew cName (map fexp2cexp args)
fexp2cexp (C.JMethod c mName args r) =
  case c of (S.NonStatic ce) -> JMethod (Right $ fexp2cexp ce) mName (map fexp2cexp args) r
            (S.Static cn)    -> JMethod (Left cn) mName (map fexp2cexp args) r
fexp2cexp (C.JField c fName r) =
  case c of (S.NonStatic ce) -> JField (Right $ fexp2cexp ce) fName (ftyp2ctyp r)
            (S.Static cn)    -> JField (Left cn) fName (ftyp2ctyp r)
fexp2cexp (C.Error ty str)         = Error (ftyp2ctyp ty) (fexp2cexp str)
fexp2cexp (C.Seq es)            = SeqExprs (map fexp2cexp es)
fexp2cexp (C.Data recflag binds e) = Data recflag (map fdatabind2cdatabind binds) (fexp2cexp e)
    where fdatabind2cdatabind (C.DataBind name params ctrs) = DataBind ('$':name) params (map fctr2cctr . ctrs)
fexp2cexp (C.ConstrOut ctr es) = ConstrOut (fctr2cctr ctr) (map fexp2cexp es)
fexp2cexp (C.Case e alts) = Case (fexp2cexp e) (map falt2calt alts)
  where falt2calt (C.ConstrAlt ctr e1) = ConstrAlt (fctr2cctr ctr) (fexp2cexp e1)
        falt2calt (C.Default e1)       = Default (fexp2cexp e1)
fexp2cexp e                         = Lam closureTransName (groupLambda e)

fctr2cctr :: C.Constructor t -> Constructor t
fctr2cctr (C.Constructor ctrname ctrparams) = Constructor ('$':ctrname) (map ftyp2ctyp ctrparams)


adjust :: C.Type t -> EScope t e -> TScope t
adjust (C.Fun t1 t2) (Type t1' g) = Type t1' (\_ -> adjust t2 (g undefined)) -- not very nice!
adjust (C.Forall _ f) (Kind g)     = Kind (\t -> adjust (f t) (g t))
adjust t (Body b)               = Body (ftyp2ctyp t)
adjust _ _ = sorry "ClosureF.adjust: no idea how to do"

{-
groupLambda2 :: C.Expr Int (Int,F.Type Int) -> [t] -> [e] -> EScope t e
groupLambda2 (FBLam f) tenv env = Kind (\a -> groupLambda2 (f (length tenv)) (a:tenv) env)
groupLambda2 (FLam t f) tenv env =
  Typ (ftyp2ctyp2 t tenv) (\x -> groupLambda2 (f (length env,t)) tenv (x:env))
-}

groupLambda :: C.Expr t e -> EScope t e
groupLambda (C.BLam _ f)  = Kind (groupLambda . f)
groupLambda (C.Lam _ t f) = Type (ftyp2ctyp t) (groupLambda . f)
groupLambda e          = Body (fexp2cexp e)

-- join

scope2ctyp :: TScope t -> Type t
scope2ctyp (Body t)  = t
scope2ctyp s         = Forall s

getArity :: TScope t -> Int
getArity (Type _ g) = 1 + getArity (g ())
getArity _ = 0

joinType :: Type (Type t) -> Type t
joinType (TVar t)   = t
joinType Unit = Unit
joinType CFInt = CFInt
joinType CFInteger = CFInteger
joinType CFChar = CFChar
joinType CFCharacter = CFCharacter
joinType (Forall s) = Forall (joinTScope s)
joinType (JClass c) = JClass c
joinType (TupleType ts) = TupleType (map joinType ts)
joinType (Datatype name params ctrnames) = Datatype name (map joinType params) ctrnames
joinType (ListType t) = ListType (joinType t)

joinTScope :: TScope (Type t) -> TScope t
joinTScope (Body b)   = Body (joinType b)
joinTScope (Kind f)   = Kind (joinTScope . f . TVar)
joinTScope (Type t f) = let t' = joinType t in Type t' (joinTScope . f)

-- Free variable substitution

substScope :: Subst t => Int -> Type Int -> TScope t  -> TScope t
substScope n t (Body t1) = Body (substType n t t1)
substScope n t (Kind f)  = Kind (substScope n t . f)
substScope n t (Type t1 f) = Type (substType n t t1) (substScope n t . f)

substType :: Subst t => Int -> Type Int -> Type t -> Type t
substType n t (TVar x) = subst n t x
substType n t (Forall s) = Forall (substScope n t s)
substType n t x = x

class Subst t where
   subst :: Int -> Type Int -> t -> Type t

instance Subst Int where
   subst n t x
      | n == x = t
      | otherwise = TVar x

instance Subst t => Subst (Type t) where
   subst n t x = TVar (substType n t x)

-- Pretty Printing
-- TODO: fix pretty printing with the propagated names
type Index = Int

isSimpleExpr :: Expr Index Index -> Bool
isSimpleExpr (Var _ _)         = True
isSimpleExpr (PrimOp{})  = True
isSimpleExpr (App (Var _ _) _) = True
isSimpleExpr (Lit _)         = True
isSimpleExpr _               = False

prettyTScope :: Prec -> Index -> TScope Index -> Doc

prettyTScope p i (Body t) = prettyType p i t

--To be modified.
prettyTScope p i (Kind f) = nest 2 (text "TScope_Kind(" <$> text "\\_ -> " <> prettyTScope p i (f 0)) <$> text ")"

prettyTScope p i (Type t f) = prettyType p i t <+> text "->" <+> prettyTScope p i (f ())

prettyEScope :: Prec -> (Index, Index) -> EScope Index Index -> Doc

prettyEScope p i (Body t) = prettyExpr p i t

--To be modified. Lack of necessary parens. (Int -> Int) -> Int -> Int.
prettyEScope p (i, j) (Kind f) = text "/\\" <+> prettyTVar i <> dot <$> prettyEScope p (succ i, j) (f i)

prettyEScope p (i, j) (Type t f) = backslash <+> parens (prettyVar j <+> colon <+> prettyType p i t) <> dot <$> prettyEScope p (i, succ j) (f j)

prettyType :: Prec -> Index -> Type Index -> Doc

prettyType _ _ (TVar t) = prettyTVar t

prettyType p i (Forall f) = prettyTScope p i f

prettyType _ _ Unit = text "Unit"

prettyType _ _ (JClass "java.lang.Integer") = text "Int"
prettyType _ _ (JClass "java.lang.String") = text "String"
prettyType _ _ (JClass "java.lang.Boolean") = text "Bool"
prettyType _ _ (JClass "java.lang.Character") = text "Char"
prettyType _ _ (JClass c) = text c
prettyType p i (ListType t) = brackets $ prettyType p i t

prettyType _ _ CFInt = text "Int"
prettyType _ _ CFInteger = text "Integer"

prettyType _ _ CFChar = text "Char"
prettyType _ _ CFCharacter = text "Character"

prettyType p i (TupleType l) = tupled (map (prettyType p i) l)
prettyType p i (Datatype n tvars _) = hsep $ text n : map (prettyType p i) tvars

prettyDef :: Prec -> (Index, Index) -> Definition Index Index -> Doc
prettyDef p (i, j) (Def fname typ e def) =
  prettyVar j <+> colon <+> pretty typ <+> equals <$> prettyExpr p (i, succ j) e <> semi <$>
  prettyDef p (i, succ j) (def j)

prettyDef p (i, j) (DefRec names sigs binds defs) = vcat (intersperse (text "and") pretty_binds) <> semi <$> pretty_body
  where
    n   = length sigs
    ids = [i..(i+n-1)]
    pretty_ids   = map prettyVar ids
    pretty_sigs  = map (pretty . fst) sigs
    pretty_defs  = map (prettyExpr p (i, j + n)) (binds ids)
    pretty_binds = zipWith3 (\pretty_id pretty_sig pretty_def ->
                  pretty_id <+> colon <+> pretty_sig <+> equals <$> pretty_def)
                  pretty_ids pretty_sigs pretty_defs
    pretty_body  = prettyDef p (i, j + n) (defs ids)

prettyDef _ _ Null = text ""

prettyExpr :: Prec -> (Index, Index) -> Expr Index Index -> Doc

prettyExpr _ _ (Var _ x) = prettyVar x

prettyExpr _ _ (FVar x) = text "FVar()"

prettyExpr p i (Lam _ e) = nest 2 (text "Lam(" <$> prettyEScope p i e) <$> text ")"

prettyExpr p i (App (Lam _ e1) e2) =
  nest 2 (text "App(" <$>
  prettyExpr p i (Lam "" e1) <> comma <$>
  prettyExpr p i e2) <$>
  text ")"

-- To be modified. Remove useless parens.
prettyExpr p i (App e1 e2) = parensIf p 4 (prettyExpr (4, PrecMinus) i e1 <+> prettyExpr (4, PrecPlus) i e2)

prettyExpr p (i, j) (TApp e t) = prettyExpr p (i, j) e <+> prettyType p i t

prettyExpr p i (PrimOp e1 op e2)
  = parens (prettyExpr p i e1 <+> pretty_op <+> prettyExpr p i e2)
  where
    pretty_op = text (Language.Java.Pretty.prettyPrint java_op)
    java_op   = case op of
                  S.Arith   op' -> op'
                  S.Compare op' -> op'
                  S.Logic   op' -> op'


prettyExpr _ _ (Lit (S.Int n))    = integer n
prettyExpr _ _ (Lit (S.String s)) = dquotes (string s)
prettyExpr _ _ (Lit (S.Bool b))   = bool b
prettyExpr _ _ (Lit (S.Char c))   = char c
prettyExpr _ _ (Lit  S.UnitLit)   = unit

prettyExpr p i (If e1 e2 e3)
  = ifPart <$> thenPart <$> elsePart
  where
    ifPart   = text "if" <+> prettyExpr (3, PrecMinus) i e1
    thenPart = if   isSimpleExpr e2
               then text "then" <+> prettyExpr (3, PrecMinus) i e2
               else nest 2 (text "then" <$> prettyExpr (3, PrecMinus) i e2)
    elsePart = if   isSimpleExpr e3
               then text "else" <+> prettyExpr (3, PrecMinus) i e3
               else nest 2 (text "else" <$> prettyExpr (3, PrecMinus) i e3)

prettyExpr p i (Tuple l) = tupled (map (prettyExpr p i) l)

--To be modified. Remove useless parens.
prettyExpr p i (Proj n e) = parensIf p 5 (prettyExpr (5, PrecMinus) i e <> text "._" <> int n)

prettyExpr p (i, j) (LetRec _ sigs binds body)
  = text "let" <+> text "rec" <$$>
    vcat (intersperse (text "and") (map (indent 2) pretty_binds)) <$$>
    nest 2 (text "in" <$> pretty_body)
  where
    n   = length sigs
    ids = [i..(i+n-1)]
    pretty_ids   = map prettyVar ids
    pretty_sigs  = map (prettyType p i) sigs
    pretty_defs  = map (prettyExpr p (i, j + n)) (binds ids)
    pretty_binds = zipWith3 (\pretty_id pretty_sig pretty_def ->
                  pretty_id <+> colon <+> pretty_sig <$$> indent 2 (equals <+> pretty_def))
                  pretty_ids pretty_sigs pretty_defs
    pretty_body  = prettyExpr p (i, j + n) (body ids)


prettyExpr p (i, j) (Let _ x f) =
  text "let" <$$>
  indent 2 (prettyVar j <+> text "=" <+> prettyExpr basePrec (i, succ j) x) <$$>
  text "in" <$$>
  indent 2 (prettyExpr basePrec (i, succ j) (f j))

prettyExpr p (i, j) (Fix _ _ t f) =
  nest 2 (text "Fix(" <$>
  backslash <+> parens (prettyVar j <+> colon <+> prettyType p i t) <> dot <$>
  prettyEScope p (i, succ j) (f j)) <$>
  text ")"

prettyExpr p i (Module pname defs) =
  maybe empty ((text "package" <+>) . pretty) pname <$> text "module" <> semi <$> prettyDef p i defs

prettyExpr p i (JNew name l) = parens (text "new" <+> text name <> tupled (map (prettyExpr p i) l))

prettyExpr p i (JMethod name m args r) = methodStr name <> dot <> text m <> tupled (map (prettyExpr basePrec i) args)
  where
    methodStr (Left x)  = text x
    methodStr (Right x) = prettyExpr (6,PrecMinus) i x

prettyExpr p i (JField name f r) = fieldStr name <> dot <> text f
  where
    fieldStr (Left x)  = text x
    fieldStr (Right x) = prettyExpr (6,PrecMinus) i x

prettyExpr p i (Error _ str) = text "error:" <+> prettyExpr p i str

prettyExpr p i (SeqExprs l) = semiBraces (map (prettyExpr p i) l)

prettyExpr p (i,j) (Data recflag databinds e) =
  text "data" <+> pretty recflag <+> (align .vsep) (map prettyDatabind databinds) <$> prettyExpr p (i,j) e
    where prettyCtr i' (Constructor ctrName ctrParams) = text ctrName <+> (hsep. map (prettyType p i') $ ctrParams)
          prettyDatabind (DataBind n tvars cons) = hsep (map text $ n:tvars) <+> align
                   (equals <+> intersperseBar (map (prettyCtr (i+ length tvars))$ cons [i..(i-1+length tvars)]) <$$> semi)

prettyExpr p i (ConstrOut (Constructor ctrName ctrParams) es) = braces (text ctrName <+> (hsep $ map (prettyExpr p i) es))

prettyExpr p (i,j) (Case e alts) =
    hang 2 $ text "case" <+> prettyExpr p (i,j) e <+> text "of" <$> align (intersperseBar (map pretty_alt alts))
    where pretty_alt (ConstrAlt c e1) =
               text (constrName c) <+> arrow <+> align (prettyExpr p (i, j) e1)
          pretty_alt (Default e1) =
               text "_" <+> arrow <+> align (prettyExpr p (i, j) e1)


<|start_filename|>frontend/FileIO.hs<|end_filename|>
{- |
Module      :  FileIO
Description :  Perform IO for the REPL
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  stable
Portability :  portable
-}

{-# LANGUAGE ScopedTypeVariables
           , DeriveDataTypeable #-}

module FileIO where

import qualified Control.Exception as E
import           Control.Monad (when)
import           Data.Data
import           System.Directory (doesFileExist)
import           System.IO

import           BackEnd
import           FrontEnd
import           JavaUtils (inferClassName, inferOutputPath)

data TransMethod = Apply
                 | Naive
                 | SNaive
                 | Stack
                 | Unbox
                 | StackAU1
                 | StackAU2
                 | BenchN
                 | BenchS
                 | BenchNA
                 | BenchSA
                 | BenchSAI1
                 | BenchSAI2
                 deriving (Eq, Show, Data, Typeable, Ord)

type Connection = (Handle, Handle)
type CompileOpt = (Int, Compilation, [TransMethod])

wrap :: Connection -> (Int -> Handle -> IO Int) -> CompileOpt -> Bool -> Bool -> String -> IO Int
wrap (inP, outP) receMsg opt flagC flagS name = do
        exist <- doesFileExist name
        if not exist
          then do
            putStrLn $ name ++ " does not exist"
            return 1
          else do
            correct <- send inP opt flagC flagS name
            case correct of
              True  -> receMsg 0 outP
              False -> return 1

source2java :: Bool -> Bool -> DumpOption -> Compilation -> String -> (FilePath, String) -> IO String
source2java supernaive optInline optDump compilation className  (filePath, source) =
  do coreExpr <- source2core optDump (filePath, source)
     core2java supernaive optInline optDump compilation className coreExpr

send :: Handle -> CompileOpt -> Bool -> Bool -> FilePath -> IO Bool
send h (n, opt, method) flagC flagS f = do
  contents <- readFile f
  -- let path = dropFileName f
  let className = inferClassName . inferOutputPath $ f
  result <- E.try (if method == [SNaive]
                   then source2java True False NoDump opt className (f, contents)
                   else source2java False False NoDump opt className (f, contents))
  case result of
    Left  (_ :: E.SomeException) ->
      do putStrLn ("\x1b[31m" ++ "invalid expression sf2Java")
         putStrLn "\x1b[0m"
         return False
    Right javaFile                   ->
      do sendMsg h (className ++ ".java")
         let file = javaFile ++ "\n" ++  "//end of file"
         sendFile h file
         when flagS $
           do putStrLn contents
              putStrLn file
         return True

receiveMsg :: Int -> Handle -> IO Int
receiveMsg err h = do
  msg <- hGetLine h
  if msg == "exit"
    then return err
    else do putStrLn msg
            receiveMsg err h

sendMsg :: Handle -> String -> IO ()
sendMsg h msg = do
  hPutStrLn h msg

sendFile :: Handle -> String -> IO ()
sendFile h f = do
  hPutStrLn h f


<|start_filename|>backend/archive/CoreNew.hs<|end_filename|>
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -Wall #-}
{- |
Module      :  CoreNew
Description :  Abstract syntax and pretty printer for the New Core.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>, <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable
-}

module CoreNew
  ( Type
  , Expr(..)
  , Context
  , Index
  , alphaEq
  , mapVar
  , fsubstTT
  , fsubstTE
  , fsubstEE
  , join
  , CoreNew.pi
  , var
  , lam
  , CoreNew.mu
  , CoreNew.pretty
  , javaInt
  , coreTypeToNew
  , coreExprToNew
  ) where

import qualified Src

import           JavaUtils
import           PrettyUtils
import qualified Core as C

import           Data.List (intersperse)
import qualified Data.Map as Map
import qualified Language.Java.Pretty (prettyPrint)
import           Prelude hiding ((<$>))
import           Text.PrettyPrint.ANSI.Leijen

-- Definition

type Type t = Expr t

data Expr e
  = Var Src.Name e
  | Lit Src.Lit

  -- Binders we have: λ, μ, Π
  | Lam Src.Name (Type e) (e -> Expr e)
  | Pi Src.Name (Type e) (e -> Type e) -- Pi (x : t) . e
  | Mu Src.Name (Type e) (e -> Expr e) -- mu (x : t) . e
  | Let Src.Name (Expr e) (e -> Expr e)
  | App (Expr e) (Expr e)

  | If (Expr e) (Expr e) (Expr e)
  | PrimOp (Expr e) Src.Operator (Expr e)
      -- SystemF extension from:
      -- https://www.cs.princeton.edu/~dpw/papers/tal-toplas.pdf
      -- (no int restriction)

  | Tuple [Expr e]     -- Tuple introduction
  | Proj Int (Expr e)  -- Tuple elimination
  | Product [Type e]   -- Type of tuple. TODO: make it dependent?
  | Unit
  | Star
  | CastUp (Expr e) (Expr e)
  | CastDown (Expr e) (Expr e) -- cast down type provided by frontend

  -- Java
  | JNew ClassName [Expr e]
  | JMethod (Src.JReceiver (Expr e)) MethodName [Expr e] ClassName
  | JField  (Src.JReceiver (Expr e)) FieldName (Type e)
  | JClass ClassName

  | Seq [Expr e]
  | Error (Type e) (Expr e)

type Context e = Map.Map e (Type e)
type Index = Int

-- Translation

coreTypeToNew :: C.Type t -> Type t -- TODO: Datatypes missing
coreTypeToNew (C.TVar n x)   = Var n x
coreTypeToNew (C.JClass c)   = JClass c
coreTypeToNew (C.Fun t1 t2)  = Pi "_" (coreTypeToNew t1) (\_ -> coreTypeToNew t2)
coreTypeToNew (C.Forall n f) = Pi n Star (coreTypeToNew . f)
coreTypeToNew (C.Product ts) = Product (map coreTypeToNew ts)
coreTypeToNew C.Unit         = Unit
coreTypeToNew _ = error "CoreNew.coreTypeToNew: translation not defined"

coreExprToNew :: C.Expr e e -> Expr e -- TODO: Datatypes missing
coreExprToNew = transExpr
  where transType = coreTypeToNew
        transExpr (C.Var n e) = Var n e
        transExpr (C.Lit l) = Lit l
        transExpr (C.Lam n t f) = Lam n (transType t) (transExpr . f)
        transExpr (C.Fix n1 n2 f t1 t) = Mu n1 (transType (C.Fun t1 t))
                                         (\e -> Lam n2 (transType t) (transExpr . f e))
        transExpr (C.Let n b e) = Let n (transExpr b) (transExpr . e)
        -- TODO: translate letrec for mutual recursion
        -- transExpr (C.LetRec ns ts bi bo) = let n = head ns
        --                                        t = head ts
        --                                      in Let n (Mu n (transType t) (\e -> transExpr . head . bi  $ [e]))
        --                                         (\e -> transExpr . bo $ [e])
        transExpr (C.BLam n f) = Lam n Star (transExpr . f)
        transExpr (C.App f e) = App (transExpr f) (transExpr e)
        transExpr (C.TApp f e) = App (transExpr f) (transType e)
        transExpr (C.If e1 e2 e3) = If (transExpr e1) (transExpr e2) (transExpr e3)
        transExpr (C.PrimOp e1 op e2) = PrimOp (transExpr e1) op (transExpr e2)
        transExpr (C.Tuple es) = Tuple (map transExpr es)
        transExpr (C.Proj i e) = Proj i (transExpr e)
        transExpr (C.JNew n es) = JNew n (map transExpr es)
        transExpr (C.JMethod callee m args c) = JMethod (fmap transExpr callee) m (map transExpr args) c
        transExpr (C.JField callee n t) = JField (fmap transExpr callee) n (transType t)
        transExpr (C.Seq es) = Seq (map transExpr es)
        transExpr (C.Error t e) = Error (transType t) (transExpr e)
        transExpr _ = error "CoreNew.coreExprToNew: translation not defined"

-- Utilities

alphaEq :: Int -> Type Index -> Type Index -> Bool
alphaEq _ (Var _ a)   (Var _ b)     = a == b
alphaEq i (Pi _ t1 f) (Pi _ t2 g)   = alphaEq (succ i) (f i) (g i) && alphaEq i t1 t2
alphaEq i (Mu _ t1 f) (Mu _ t2 g)   = alphaEq (succ i) (f i) (g i) && alphaEq i t1 t2
alphaEq _ (JClass c)   (JClass d)   = c == d
alphaEq i (Product ss) (Product ts) = length ss == length ts && uncurry (alphaEq i) `all` zip ss ts
alphaEq _  Unit         Unit        = True
alphaEq _  _            _           = False

mapVar :: (Src.Name -> e -> Expr e) -> (Type e -> Type e) -> Expr e -> Expr e
mapVar g _ (Var n a)                 = g n a
mapVar _ _ (Lit n)                   = Lit n
mapVar g h (Lam n t f)               = Lam n (h t) (mapVar g h . f)
mapVar g h (Pi n t f)                = Pi n (h t) (mapVar g h . f)
mapVar g h (Mu n t f)                = Mu n (h t) (mapVar g h . f)
mapVar g h (Let n b e)               = Let n (mapVar g h b) (mapVar g h . e)
mapVar g h (App f e)                 = App (mapVar g h f) (mapVar g h e)
mapVar g h (CastUp f e)              = CastUp (mapVar g h f) (mapVar g h e)
mapVar g h (CastDown t e)            = CastDown (mapVar g h t) (mapVar g h e)
mapVar g h (If p b1 b2)              = If (mapVar g h p) (mapVar g h b1) (mapVar g h b2)
mapVar g h (PrimOp e1 op e2)         = PrimOp (mapVar g h e1) op (mapVar g h e2)
mapVar g h (Tuple es)                = Tuple (map (mapVar g h) es)
mapVar g h (Proj i e)                = Proj i (mapVar g h e)
mapVar g h (Product ts)              = Product (map (mapVar g h) ts)
mapVar _ _ Unit                      = Unit
mapVar _ _ Star                      = Star
mapVar g h (JNew c args)             = JNew c (map (mapVar g h) args)
mapVar g h (JMethod callee m args c) = JMethod (fmap (mapVar g h) callee) m (map (mapVar g h) args) c
mapVar g h (JField  callee f c)      = JField (fmap (mapVar g h) callee) f (h c)
mapVar _ _ (JClass c)                = JClass c
mapVar g h (Seq es)                  = Seq (map (mapVar g h) es)
mapVar g h (Error ty str)            = Error (h ty) (mapVar g h str)

fsubstEE :: Eq a => a -> Expr a -> Expr a -> Expr a
fsubstEE x r = mapVar (\n a -> if a == x then r else Var n a) id

fsubstTE :: Eq t => t -> Type t -> Expr t -> Expr t
fsubstTE x r = mapVar Var (fsubstTT x r)

fsubstTT :: Eq a => a -> Type a -> Type a -> Type a
fsubstTT = fsubstEE

join :: Type (Type t) -> Type t
join (Var _ a)    = a
join (Pi n t f)   = Pi n (join t) (join . f . Var "_")
join (Mu n t f)   = Mu n (join t) (join . f . Var "_")
join (JClass c)   = JClass c
join (Product ts) = Product (map join ts)
join  Unit        = Unit
join  Star        = Star
join _            = error "CoreNew.join: behavior not defined"

pi :: Type t -> (t -> Type t) -> Type t
pi = Pi "_"

var :: e -> Expr e
var = Var "_"

lam :: Type e -> (e -> Expr e) -> Expr e
lam = Lam "_"

mu :: Type e -> (e -> Expr e) -> Expr e
mu = Mu "_"

-- instance Show (Type Index) where
--   show = show . pretty

-- instance Pretty (Type Index) where
--   pretty = prettyType

pretty :: Expr Index -> Doc
pretty = pretty' basePrec 0

pretty' :: Prec -> Index -> Expr Index -> Doc
pretty' _ _ (Var n _)   = text n
pretty' _ i (Product ts) = parens $ hcat (intersperse comma (map (pretty' basePrec i) ts))
pretty' _ _  Unit = text "Unit"
pretty' _ _  Star = text "*"
pretty' _ _ (JClass "java.lang.Integer")   = text "Int"
pretty' _ _ (JClass "java.lang.String")    = text "String"
pretty' _ _ (JClass "java.lang.Boolean")   = text "Bool"
pretty' _ _ (JClass "java.lang.Character") = text "Char"
pretty' _ _ (JClass c)                     = text c

pretty' p i (Lam n t f)
  = parensIf p 2 $ group $ hang 2 $
      lambda <+> parens (text n <+> colon <+> pretty' basePrec i t) <+> text "->" <$>
      pretty' (2,PrecMinus) (i + 1) (f i)

pretty' p i (Pi n t f) = parensIf p 2 $ group $ hang 2 $
  (if n == "_"
     then pretty' basePrec i t
     else parens (text n <+> colon <+> pretty' basePrec i t)) <+> text "->" <$>
  pretty' (2, PrecMinus) (i + 1) (f i)

pretty' p i (Mu n t f)
  = parensIf p 2 $ group $ hang 2 $
      PrettyUtils.mu <+> parens (text n <+> colon <+> pretty' basePrec i t) <+> text "->" <$>
      pretty' (2,PrecMinus) (i + 1) (f i)

pretty' p i (App e1 e2)
  = parensIf p 4 $
      group $ hang 2 $ pretty' (4,PrecMinus) i e1 <$> pretty' (4,PrecPlus) i e2

pretty' p i (CastUp t e)
  = parensIf p 2 $ group $ hang 2 $ castup <> (brackets (pretty' (2, PrecMinus) i t)) <+> pretty' (2, PrecMinus) i e

pretty' p i (CastDown t e)
  = parensIf p 2 $ group $ hang 2 $ castdown <> (brackets (pretty' (2, PrecMinus) i t)) <+> pretty' (2, PrecMinus) i e


pretty' _ _ (Lit (Src.Int n))    = integer n
pretty' _ _ (Lit (Src.String s)) = dquotes (string s)
pretty' _ _ (Lit (Src.Bool b))   = bool b
pretty' _ _ (Lit (Src.Char c))   = char c
pretty' _ _ (Lit Src.UnitLit)    = unit

pretty' p i (If e1 e2 e3)
  = parensIf p prec
      (hang 3 (text "if"   <+> pretty' (prec,PrecMinus) i e1 <+>
               text "then" <+> pretty' (prec,PrecMinus) i e2 <+>
               text "else" <+> pretty' (prec,PrecMinus) i e3))
  where prec = 3

pretty' p i (PrimOp e1 op e2)
  = parens (pretty' p i e1 <+> pretty_op <+> pretty' p i e2)
  where
    pretty_op = text (Language.Java.Pretty.prettyPrint java_op)
    java_op   = case op of
                  Src.Arith   op' -> op'
                  Src.Compare op' -> op'
                  Src.Logic   op' -> op'

pretty' _ i (Tuple es) = tupled (map (pretty' basePrec i) es)

pretty' p i (Proj n e) =
  parensIf p 5
    (pretty' (5,PrecMinus) i e <> dot <> char '_' <> int n)

pretty' _ i (JNew c args) =
  parens (text "new" <+> text c <> tupled (map (pretty' basePrec i) args))

pretty' _ i (JMethod name m args _) = methodStr name <> dot <> text m <> tupled (map (pretty' basePrec i) args)
  where
    methodStr (Src.Static x) = text x
    methodStr (Src.NonStatic x) = pretty' (6,PrecMinus) i x

pretty' _ i (JField name f _) = fieldStr name <> dot <> text f
  where
    fieldStr (Src.Static x) = text x
    fieldStr (Src.NonStatic x) = pretty' (6,PrecMinus) i x

pretty' p i (Error _ str) = text "error:" <+> pretty' p i str

pretty' p i (Seq es) = semiBraces (map (pretty' p i) es)

pretty' _ i (Let n b e) =
  text "let" <+> text n <+> equals <+> pretty' basePrec (succ i) b <$> text "in" <$>
  pretty' basePrec (succ i) (e i)

javaInt :: Type t
javaInt = JClass "java.lang.Integer"


<|start_filename|>runtime/src/f2j/unbox/ClosureIntInt.java<|end_filename|>
package f2j.unbox;

public abstract class ClosureIntInt implements Closure
{
  public int arg;
  public int res;
  public boolean hasApply = true;
  public abstract void apply () ;
  public ClosureIntInt clone () {
      return (ClosureIntInt) ((Object) this.clone());
  }
}


<|start_filename|>backend/PartialEvaluator.hs<|end_filename|>
{-# LANGUAGE ViewPatterns #-}
{- |
Module      :  PartialEvaluator
Description :  Partial evaluation of FCore
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  Jeremy <<EMAIL>>, Weixin <<EMAIL>>
Stability   :  experimental
Portability :  portable

This module implements partial evaluation of FCore. It also includes
an experimental term rewriting process.
-}

module PartialEvaluator (rewriteAndEval, Exp(..), rewrite1, rewrite2, rewrite3) where

import Core
import OptiUtils
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)

app2let :: Expr t e -> Expr t e
app2let (App e1 e2) = case e1' of
  Lam _ _ f    -> Let "x" e2' f
  Let n body f -> Let n body (\x -> app2let (App (f x) e2'))
  _            -> App e1' e2'
  where
    e1' = app2let e1
    e2' = app2let e2
app2let e = mapExpr app2let e

-- Rule 1: let x = y in e                 => [x -> y] e   (where y is a variable)
rewrite1 :: Expr t e -> Expr t e
rewrite1 (Let _ (Var _ n) f) = rewrite1 (f n)
rewrite1 e = mapExpr rewrite1 e

-- transform single self recursion to fix (TODO: workaround)
rewrite0 :: Expr t Int -> Expr t e
rewrite0 = swap1_3 rewrite0' 0 Map.empty

rewrite0' :: Map.Map Int e -> Expr t Int -> Int -> Expr t e
rewrite0' env e@(LetRec names [Fun t1 t2] binds expr) num =
  case head (binds [num]) of
    Lam _ _ body ->
      Let
        (head names)
        (fix
           (\f arg ->
              rewrite0' (Map.insert (num + 1) arg (Map.insert num f env)) (body (num + 1)) (num + 2))
           t1
           t2)
        (\es -> rewrite0' (Map.insert num es env) (expr [num]) (num + 1))
    _ ->
      rewriteExpr (swap1_3 rewrite0') num env e
rewrite0' env t num = rewriteExpr (swap1_3 rewrite0') num env t

-- Rule 2: let x = e in x                 =>  e
rewrite2 :: Expr t Int -> Expr t e
rewrite2 = swap1_3 rewrite2' 0 Map.empty

rewrite2' :: Map.Map Int e -> Expr t Int -> Int -> Expr t e
rewrite2' env e@(Let _ expr f) num@(f -> (Var _ num')) =
  if num' == num
  then rewrite2' env expr num
  else rewriteExpr (swap1_3 rewrite2') num env e
rewrite2' env e num = rewriteExpr (swap1_3 rewrite2') num env e

-- Rule 3: (\x . y x)                     => y (where y is a variable)
rewrite3 :: Expr t Int -> Expr t e
rewrite3 = swap1_3 rewrite3' 0 Map.empty

rewrite3' :: Map.Map Int e -> Expr t Int -> Int -> Expr t e
rewrite3' env e@(Lam _ _ f) num@(f -> App (Var n' y) (Var _ num')) =
  if num' == num
  then Var n' (fromJust $ Map.lookup y env)
  else rewriteExpr (swap1_3 rewrite3') num env e
rewrite3' env e num = rewriteExpr (swap1_3 rewrite3') num env e

peval :: Expr t e -> Expr t e
peval = rewrite1 .  app2let

partialEval :: Exp -> Exp
partialEval e = Hide (peval (reveal e))

rewriteCombined :: Exp -> Exp
rewriteCombined e = Hide (rewrite3 . rewrite2 . rewrite0 . reveal $ e)

rewriteForever :: Exp -> [Exp]
rewriteForever e = e : rewriteForever (rewriteCombined e)

-- Need proof for convergence.
converge :: [Exp] -> Exp
converge ~(a1:a2:es) =
  if a1 == a2
     then a2
     else converge (a2 : es)

rewrite :: Exp -> Exp
rewrite e = rewriteForever e !! 4

rewriteAndEval :: Exp -> Expr t e
rewriteAndEval =
  reveal . rewrite . partialEval


-- Just for convenience to use view pattern
swap1_3 :: (b -> c -> a -> d) -> a -> b -> c -> d
swap1_3 f a b c = f b c a

-- calc :: Expr t (Expr t e) -> Expr t (Expr t e)
-- calc (App e1 e2) =
--     case (e1', e2') of
--       (Lam _ _ f, Lit _) -> calc . f . joinExpr $ e2'
--       _ -> App e1' e2'
--     where e1' = calc e1
--           e2' = calc e2
-- calc (Let n bind body) =
--     case bind' of
--       Lit _ -> calc . body . joinExpr $ bind'
--       _ -> Let n bind' (\x -> calc . body $ x)
--      where bind' = calc bind
-- calc (PrimOp e1 op e2) =
--     case (e1', e2') of
--       (Lit (S.Int a), Lit (S.Int b)) ->
--           case op of
--             -- arithmetic operations
--             S.Arith J.Sub -> Lit . S.Int $ a - b
--             S.Arith J.Add -> Lit . S.Int $ a + b
--             S.Arith J.Mult -> Lit . S.Int $ a * b
--             S.Arith J.Div -> Lit . S.Int $ a `div` b
--             S.Arith J.Rem -> Lit . S.Int $ a `rem` b
--             -- comparison operations
--             S.Compare J.Equal -> Lit . S.Bool $ a == b
--             S.Compare J.NotEq -> Lit . S.Bool $ a /= b
--             S.Compare J.LThan -> Lit . S.Bool $ a < b
--             S.Compare J.LThanE -> Lit . S.Bool $ a <= b
--             S.Compare J.GThan -> Lit . S.Bool $ a > b
--             S.Compare J.GThanE -> Lit . S.Bool $ a >= b
--             _ -> simplified
--       (Lit (S.Bool a), Lit (S.Bool b)) ->
--           case op of
--             -- logic operations
--             S.Logic J.CAnd -> Lit . S.Bool $ a && b
--             S.Logic J.COr -> Lit . S.Bool $ a || b
--             _ -> simplified
--       _ -> simplified
--     where e1' = calc e1
--           e2' = calc e2
--           simplified = PrimOp e1' op e2'
-- calc (If e1 e2 e3) =
--     case e1' of
--       Lit (S.Bool True) -> calc e2
--       Lit (S.Bool False) -> calc e3
--       _ -> If e1' (calc e2) (calc e3)
--     where e1' = calc e1
-- calc e = mapExpr calc e


<|start_filename|>examples/case_studies/RedBlackTree.hs<|end_filename|>
{-# LANGUAGE TemplateHaskell #-}

module RedBlackTree where

{-
1 try "runTests" to test all the properties
2 try "multiTestNv" to test the naive version of "prop_buggyInsNv" with time showed below
3 try "multiTestCl" to test the clever version of "prop_buggyInsCl" with time showed below
-}

import Test.QuickCheck
import Test.QuickCheck.All
import qualified Data.Set as Set
import MonadLib
import System.CPUTime
import System.Timeout



--"type for Color and Tree"
data Color = Red | Black deriving(Show,Eq)

data Tree = Empty | Node Color Tree Int Tree deriving(Show,Eq)


  ------------test data generator for Color--------------------------
instance Arbitrary Color where
  arbitrary = oneof [return Red, return Black]

  ------------test data generator for Tree---------------------------
instance Arbitrary Tree where
  arbitrary = sized arbTree
  shrink = shrinkTree

arbTree :: Int -> Gen Tree
arbTree 0 = return Empty
arbTree n = frequency
  [ (1, return Empty)
  , (4, liftM4 Node (oneof [return Red, return Black])
                    (arbTree (n `div` 2))
                    (choose (-65536,65536))
                    (arbTree (n `div` 2))) ]

shrinkTree :: Tree -> [Tree]
shrinkTree (Node c l v r) = [Node c l' v r | l' <- shrinkTree l] ++
                            [Node c l v' r | v' <- shrink v] ++
                            [Node c l v r' | r' <- shrinkTree r] ++
                            [Empty]
shrinkTree _              = []

---------------------------------------------------------------------

-------Generate black-balanced trees with no red-red violations:------

lg :: Int -> Int
lg n = round(logBase (fromIntegral(2)) (fromIntegral(n)))

rbTree :: Gen Tree
rbTree = sized (\n -> arbRBTree Black (lg(n))) where

 arbRBTree :: Color -> Int -> Gen Tree
 arbRBTree Black 0 = return Empty
 arbRBTree Black 1 =
   oneof [return Empty,
          liftM4 Node (return Red) (return Empty)
                      (choose (-65536,65536)) (return Empty)]

 arbRBTree Black n | n>0 =
   oneof [liftM4 Node (return Black) subtree arbnum subtree,
          liftM4 Node (return Red) subtree' arbnum subtree']
   where subtree  = arbRBTree Black (n-1)
         subtree' = arbRBTree Red n
         arbnum   = (choose (-65536,65536))

 arbRBTree Red 0 = return Empty
 arbRBTree Red 1 = return Empty
 arbRBTree Red n | n>0 =
   oneof [liftM4 Node (return Black) subtree arbnum subtree]
   where subtree = arbRBTree Black (n-1)
         arbnum  = (choose (-65536,65536))

---------------------------------------------------------------


--function "content" using Set which is interior in Data.Set
content :: Tree -> (Set.Set Int)
content Empty = Set.empty
content (Node _ l v r) = Set.unions
                         [(content l), (Set.singleton v),(content r)]

--function "size"
size :: Tree -> Int
size Empty = 0
size (Node _ l v r) = (size l) + 1 + (size r)


--function "isBlack"
isBlack :: Tree -> Bool
isBlack Empty = True
isBlack (Node Black _ _ _) = True
isBlack _ = False


--function "redNodesHaveBlackChildren"
redNodesHaveBlackChildren :: Tree -> Bool
redNodesHaveBlackChildren Empty = True
redNodesHaveBlackChildren (Node Black l _ r) = redNodesHaveBlackChildren l && redNodesHaveBlackChildren r
redNodesHaveBlackChildren (Node Red l _ r) = isBlack l &&
                                        isBlack r &&
                                        redNodesHaveBlackChildren l &&
                                        redNodesHaveBlackChildren r

isRBT :: Tree -> Bool
isRBT t = redNodesHaveBlackChildren t && blackBalanced t

--function "redDescHaveBlackChildren"
redDescHaveBlackChildren :: Tree -> Bool
redDescHaveBlackChildren Empty = True
redDescHaveBlackChildren (Node _ l _ r) = redNodesHaveBlackChildren l
                                       && redNodesHaveBlackChildren r

--function "blackBalanced"
blackBalanced :: Tree -> Bool
blackBalanced Empty = True
blackBalanced (Node _ l _ r) = blackBalanced l && blackBalanced r
                             && (blackHeight l) == (blackHeight r)

--function "blackHeight"
blackHeight :: Tree -> Int
blackHeight Empty = 1
blackHeight (Node Black l _ _) = (blackHeight l) + 1
blackHeight (Node Red l _ _) = (blackHeight l)


--function "ins" (insert an element into a tree)
ins :: Int -> Tree -> Tree
ins x t
   | (redNodesHaveBlackChildren t) && (blackBalanced t)
        = case t of
            Empty -> Node Red Empty x Empty
            (Node c a y b) ->   if x < y then balance c (ins x a) y b
                                else if x == y then Node c a y b
                                     else balance c a y (ins x b)
   | otherwise = error "The tree is not a Red-Black-Tree"



----test for "ins"
pprop_ins :: Int -> Tree -> Property
pprop_ins x t = (redNodesHaveBlackChildren t) && (blackBalanced t) ==>
     -- forAll rbTree $ \ t ->
         collect (size t) $
         content (ins x t) == Set.union (content t) (Set.singleton x)
    .&&. (size t) <= (size (ins x t))
    .&&. (size (ins x t)) <= (size t) + 1
    .&&. redDescHaveBlackChildren (ins x t)
    .&&. blackBalanced (ins x t)

prop_ins :: Int -> Tree -> Bool
prop_ins x t =
    --  forAll rbTree $ \ t ->
         content (ins x t) == Set.union (content t) (Set.singleton x)
    && (size t) <= (size (ins x t))
    && (size (ins x t)) <= (size t) + 1
    && redDescHaveBlackChildren (ins x t)
    && blackBalanced (ins x t)


prop_buggyInsNv :: Int -> Tree -> Property
prop_buggyInsNv x t = (redNodesHaveBlackChildren t) && (blackBalanced t) ==>
         content (ins x t) == Set.union (content t) (Set.singleton x)
    .&&. (size t) < (size (ins x t))
    .&&. (size (ins x t)) <= (size t) + 1
    .&&. redDescHaveBlackChildren (ins x t)
    .&&. blackBalanced (ins x t)


prop_buggyInsCl :: Int -> Property
prop_buggyInsCl x =
         forAll rbTree $ \ t ->
         content (ins x t) == Set.union (content t) (Set.singleton x)
    .&&. (size t) < (size (ins x t))
    .&&. (size (ins x t)) <= (size t) + 1
    .&&. redDescHaveBlackChildren (ins x t)
    .&&. blackBalanced (ins x t)



--function "makeBlack"
makeBlack :: Tree -> Tree
makeBlack t = case t of
                (Node Red l v r) -> Node Black l v r
                t -> t

----test for "makeBlack"
prop_makeBlack :: Property
prop_makeBlack = --(redDescHaveBlackChildren t)&&(blackBalanced t) ==>
         forAll rbTree $ \ t ->
         collect (size t) $
         redNodesHaveBlackChildren (makeBlack t) .&&. blackBalanced (makeBlack t)


--function "add"
add :: Int -> Tree -> Tree
add n t = makeBlack (ins n t)


----test for "add"
prop_add :: Int -> Property
prop_add n = -- (redNodesHaveBlackChildren t) && (blackBalanced t) ==>
         forAll rbTree $ \ t ->
         collect (size t) $
         content (add n t) == Set.union (content t) (Set.singleton n)
    .&&. redDescHaveBlackChildren (add n t)
    .&&. blackBalanced (add n t)


buggyAdd :: Int -> Tree -> Tree
buggyAdd n t = ins n t


----test for "buggyAdd"
prop_buggyAdd :: Int -> Property
prop_buggyAdd n = -- redNodesHaveBlackChildren t && (blackBalanced t) ==>
         forAll rbTree $ \ t ->
         collect (size t) $
         content (buggyAdd n t) == Set.union (content t) (Set.singleton n)
    .&&. redNodesHaveBlackChildren (buggyAdd n t)
    .&&. blackBalanced (buggyAdd n t)


--function "balance"
balance :: Color -> Tree -> Int -> Tree -> Tree
balance Black (Node Red (Node Red a xV b) yV c) zV d =
              Node Red (Node Black a xV b) yV (Node Black c zV d)

balance Black (Node Red a xV (Node Red b yV c)) zV d =
              Node Red (Node Black a xV b) yV (Node Black c zV d)

balance Black a xV (Node Red (Node Red b yV c) zV d) =
              Node Red (Node Black a xV b) yV (Node Black c zV d)

balance Black a xV (Node Red b yV (Node Red c zV d)) =
              Node Red (Node Black a xV b) yV (Node Black c zV d)

balance c a xV b = Node c a xV b

----test for "balance"
prop_balance :: Color -> Tree -> Int -> Tree -> Property
prop_balance c a x b =
            collect (size (Node c a x b)) $
                       content (balance c a x b) ==
                       content (Node c a x b)


--function "buggyBalance"
buggyBalance :: Color -> Tree -> Int -> Tree -> Tree
buggyBalance Black (Node Red (Node Red a xV b) yV c) zV d =
              Node Red (Node Black a xV b) yV (Node Black c zV d)
buggyBalance Black (Node Red a xV (Node Red b yV c)) zV d =
              Node Red (Node Black a xV b) yV (Node Black c zV d)
buggyBalance Black a xV (Node Red (Node Red b yV c) zV d) =
              Node Red (Node Black a xV b) yV (Node Black c zV d)
buggyBalance Black a xV (Node Red b yV (Node Red c zV d)) =
              Node Red (Node Black a xV b) yV (Node Black c zV d)

----test for "buggyBalance"
prop_buggyBalance :: Color -> Tree -> Int -> Tree -> Bool
prop_buggyBalance c a x b = content (buggyBalance c a x b) ==
                            content (Node c a x b)





----------------------------timer--------------------------------
timeIt :: (Fractional c) => (a -> IO b) -> a -> IO c
timeIt action arg = do
       startTime <- getCPUTime
       action arg
       finishTime <- getCPUTime
       return $ fromIntegral (finishTime - startTime)  / 1000000000

--timeIt' :: (Fractional c) => (a -> b) -> a -> IO c
--timeIt' f = timeIt (\x -> f x `seq` return())

oneTestNv = timeout 5000000 $ timeIt quickCheck prop_buggyInsNv >>= print
oneTestCl = timeout 5000000 $ timeIt quickCheck prop_buggyInsCl >>= print

multiTestNv = do
            startTime <- getCPUTime
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000

multiTestCl = do
            startTime <- getCPUTime
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000



------for-quickCheck-test------
return []                    --
runTests = $quickCheckAll    --
-------------------------------










<|start_filename|>runtime/src/f2j/unbox/ClosureBoxInt.java<|end_filename|>
package f2j.unbox;

public abstract class ClosureBoxInt implements Closure
{
  public Object arg;
  public int res;
  public boolean hasApply = true;
  public abstract void apply () ;
  public ClosureBoxInt clone () {
      return (ClosureBoxInt) ((Object) this.clone());
  }
}


<|start_filename|>frontend/Z3ModelParser.hs<|end_filename|>
{- |
Module      :  Z3ModelParser
Description :  A parser for parsing Z3 model format
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  unstable
Portability :  portable
-}

module Z3ModelParser where

import           Data.Char                     (toUpper)
import qualified Data.IntMap                   as IntMap
import           Text.ParserCombinators.Parsec

-- TODO: unknown format: application?
-- Cons -> {
--   (Cons!2885 (k!2883 (:var 0)) (k!2884 (:var 1)))
-- }
-- NOTE: Use `try` when alternatives share one prefix, otherwise the stream will be consumed

parseModel :: String -> [Bind]
parseModel input = case parse binds "parse error" input of
                     Left err -> error $ show err
                     Right bs -> bs

type Bind = (MIdent, MExpr)

data MIdent = MIntSymbol Int
            | MStringSymbol String
            | MElemSymbol Int -- elem!i
            | MLetSymbol Int -- a!i
-- The constant elem!i is an auxiliary constant created by Z3 during the solving process [http://stackoverflow.com/questions/12899521/understanding-the-z3-model]

isMIntSymbol :: MIdent -> Bool
isMIntSymbol (MIntSymbol _) = True
isMIntSymbol _ = False

data MExpr = MApp MOp [MExpr]
           | MLet [Bind] MExpr -- a!i
           | MValue MValue

counterExample :: Int -> String -> String
counterExample total = ("Counter example:\n" ++ ) . unlines . map (\(i,e) -> "x" ++ show i ++ " = " ++ show e) . relevantBinds total . parseModel

relevantBinds :: Int -> [Bind] -> [(Int, MExpr)]
relevantBinds total bs =
    [(i, substLet e) | (b, e) <- bs, isMIntSymbol b, let MIntSymbol i = b, i < total]

substLet :: MExpr -> MExpr
substLet = go IntMap.empty
    where go env (MLet bs e) = go (foldr (\(MLetSymbol i, e') acc -> IntMap.insert i (go env e') acc) env bs) e
          go env e@(MValue v) =
              case v of
                MIdent (MLetSymbol i) -> env IntMap.! i
                _ -> e
          go env (MApp op es) = MApp op (map (go env) es)

data MOp = MOp String
         | Minus
         | Mult

data MValue = MInt Int
            | MBool Bool
            | MSort String Int -- ident!val!i
            | MIdent MIdent
            | MFun [MRule] -- [in] -> out 1. [([],val)]: zero-arg fun. 2. [..., ([],val)]:
type MRule = ([MExpr], MExpr)

showBinds :: [Bind] -> String
showBinds = init . unlines . map showBind

showBind :: Bind -> String
showBind (x,v) = show x ++ " -> " ++ show v

instance Show MIdent where
    show (MIntSymbol i) = "k!" ++ show i
    show (MStringSymbol s) = s
    show (MElemSymbol i) = "elem!" ++ show i
    show (MLetSymbol i) = "a!" ++ show i

instance Show MExpr where
    show (MApp op vs) = "(" ++ unwords (show op : map show vs) ++ ")"
    show (MLet [(i,e)] expr) = "(let (" ++ ("(" ++ show i ++ " " ++ show e ++ ")") ++ ")\n" ++ "  " ++ show expr ++ ")"
    show (MValue v) = show v

instance Show MValue where
    show (MInt i) = show i
    show (MBool b) = let c:cs = show b in toUpper c : cs
    show (MSort s i) = s ++ "!val!" ++ show i
    show (MFun [([], v)]) = "{" ++ "\n  " ++ show v ++ "\n" ++ "}"
    show (MFun rs) = unlines ("{" : map showRule rs) ++ "}"
    show (MIdent sym) = show sym

instance Show MOp where
    show (MOp s) = s
    show Minus = "-"
    show Mult = "*"

showRule :: MRule -> String
showRule ([], e) = "  _ -> " ++ show e
showRule (es, e) = "  " ++ unwords (map show es) ++ " -> " ++ show e

arrow :: Parser String
arrow = string "->"

-- parens p = between (char ')') (char '(') p

binds :: Parser [Bind]
binds = sepEndBy bind newline

-- model ::= symbol " -> " value
bind :: Parser Bind
bind = do
  n <- symbol
  space
  arrow
  space
  e <- expr
  return (n, e)

-- symbol ::= intSymbol | stringSymbol | letSymbol | stringSymbol
symbol :: Parser MIdent
symbol = intSymbol <|> elemSymbol <|> letSymbol <|> stringSymbol

-- intSymbol ::= k!int
intSymbol :: Parser MIdent
intSymbol = do
  try $ string "k!"
  i <- digits
  return $ MIntSymbol i

-- opSymbol :: Parser MIdent
-- opSymbol = oneOf "-*/+" >>= \op -> return $ MOp op

digits :: Parser Int
digits = read <$> many1 digit

stringSymbol :: Parser MIdent
stringSymbol = MStringSymbol <$> ident

elemSymbol :: Parser MIdent
elemSymbol = do
  try $ string "elem!"
  i <- digits
  return $ MElemSymbol i

-- expr ::= app
--        | let (letbinds) expr
--        | value
expr :: Parser MExpr
expr = try letExpr <|> app <|> MValue <$> value

letExpr :: Parser MExpr
letExpr = do
  char '('
  string "let "
  char '('
  -- binds <- many1 (letBind >>= \b -> many (newline <|> space) >> b)
  bind <- letBind
  char ')'
  newline
  spaces
  e <- expr
  char ')'
  return $ MLet [bind] e

letBind = do
  char '('
  sym <- letSymbol
  space
  e <- expr
  char ')'
  return (sym, e)

letSymbol :: Parser MIdent
letSymbol = do
  string "a!"
  i <- digits
  return $ MLetSymbol i

-- app ::= (op values)
app :: Parser MExpr
app = do char '('
         o <- op
         es <- many1 (space >> expr)
         char ')'
         return $ MApp o es
-- op ::= UpperId
--      | -
op :: Parser MOp
op = (char '-' >> return Minus) <|> (char '*' >> return Mult) <|> (MOp <$> ident)

-- value ::= int
--         | bool
--         | sort
--         | let
--         | app
--         | fun
--         | symbol
value :: Parser MValue
value = fun
        <|> int
        <|> try bool
        <|> try sort
        <|> MIdent <$> symbol

-- int ::= digit+ | (- digit+)
int :: Parser MValue
int = MInt <$> digits

-- bool ::= true | false
bool :: Parser MValue
bool =
    do b <- string "true" <|> string "false"
       return $ case b of
                  "true" -> MBool True
                  _ -> MBool False

-- sort ::= id!val!int
sort :: Parser MValue
sort = do
  n <- ident
  string "!val!"
  i <- digits
  return $ MSort n i

ident :: Parser String
ident = many (alphaNum <|> char '_')

-- fun ::= { rules }
fun :: Parser MValue
fun = do
  char '{'
  rs <- rules
  char '}'
  return $ MFun rs

rules :: Parser [MRule]
rules = many1 (try rule0 <|> rule)

-- rules ::= spaces [value space]+ -> value
rule :: Parser MRule
rule = do
  spaces
  es <- many1 (expr >>= \e -> space >> return e)
  arrow
  space
  res <- expr
  newline
  return (es, res)

-- rule0 ::= [else ->] value\n}
rule0 :: Parser MRule
rule0 = do
  spaces
  optionMaybe (string "else -> ")
  res <- expr
  newline
  return ([], res)

showParsed = showBinds . parseModel
putParsed = putStrLn . showParsed


<|start_filename|>frontend/Desugar.hs<|end_filename|>
{- |
Module      :  Desugar
Description :  The desugarer turns the source language into System FI.
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3
Maintainer  :  <NAME> <<EMAIL>>
Stability   :  experimental
Portability :  portable

The desugarer turns the source language into System FI,
including the removal of type synonyms. No desugaring should happen before this
stage.
-}


{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Desugar (desugar) where

import           Panic
import           Src
import           SrcLoc
import           StringPrefixes
import qualified SystemFI as F

import           Data.List (intercalate)
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe)
import qualified Data.Set as Set (member)
import           Text.PrettyPrint.ANSI.Leijen


-- | Generate a fresh variable in the context. This is a very general API and
-- requires caution from the user, that is, it is the responsibility of the user
-- to ensure that the fresh variable is inserted to VarMap in the ensuing code.
-- For example,
--
--     `Map.insert x (F.Var x x') g`
-- where x' is a bound *Haskell* variable.
--
-- Example:
-- If you want a fresh variable at the position denoted by "?" in the following
-- program, ``\x. \y. \?. e` with the current `VarMap` being `g`, then you can
-- write `let x = generateFreshVar g in ...` so that inside `...` you have
-- the fresh variable `x` as well as the updated `VarMap` `g1`.
--
-- The generated variable is guaranteed to be distinct:
-- 1) with all variables introduced at the outer scope (therefore
-- in this case, "?" will be neither "x" not "y"); and
-- 2) with all free variables of `e`, so that "?" will not accidently capture them.
--
-- A note on the implementation: For the sake of performance & convenience,
-- we do not compute the free variables of `e`, since at the stage of this
-- module, we can assume that `e` does not contain free variables that are not
-- captured by the outer scope. In other words, FV(e) \ FV(Γ) is empty.
generateFreshVar :: VarMap t e -> Name
generateFreshVar g0 = try g0 1
  where
    try :: VarMap t e -> Int -> Name
    try g n
      | fresh_var n `Set.member` Map.keysSet g = try g (n + 1)
      | otherwise                              = fresh_var n
    fresh_var n = "fresh" ++ show n


desugar :: CheckedExpr -> F.Expr t e
desugar = desugarExpr (Map.empty, Map.empty)

type TVarMap t  = Map.Map Name t
type VarMap t e = Map.Map Name (F.Expr t e)

transType :: TVarMap t -> Type -> F.Type t
transType d (TVar a)     = F.TVar a (fromMaybe (panic ("transType: " ++ show (TVar a))) (Map.lookup a d))
transType _ (JClass c)   = F.JClass c
transType d (Fun t1 t2)  = F.Fun (transType d t1) (transType d t2)
transType d (TupleType ts) = F.Product (map (transType d) ts)
transType d (Forall (a,_) t) = F.Forall a (\a' -> transType (Map.insert a a' d) t)
transType d (And t1 t2)  = F.And (transType d t1) (transType d t2)
transType d (RecordType fs)  =
                case fs  of
                  [(l,t)]  -> F.RecordType (l, transType d t)
                  _        -> transType d (RecordType (take (length fs - 1) fs)) `F.And` F.RecordType (let (l,t) = last fs in (l,transType d t))
transType _ Unit         = F.Unit
transType i (Datatype n ts ns) = F.Datatype n (map (transType i) ts) ns
transType _ t            = prettySorry "transType" (pretty t)


desugarExpr :: (TVarMap t, VarMap t e) -> CheckedExpr -> F.Expr t e
desugarExpr (d, g) = go
  where
    go (L _ (Var (x,t)))       = fromMaybe (panic "desugarExpr: Var") (Map.lookup x g)
    go (L _ (Lit lit))         = F.Lit lit
    go (L _ (App f x))         = F.App (go f) (go x)
    go (L _ (TApp e t))        = F.TApp (go e) (transType d t)
    go (L _ (TupleCon es))     = F.Tuple (map go es)
    go (L _ (TupleProj e i))   = F.Proj i (go e)
    go (L _ (PrimOp e1 op e2)) = F.PrimOp (go e1) op (go e2)
    go (L _ (If e1 e2 e3))     = F.If (go e1) (go e2) (go e3)
    go (L _ (Lam (L _ x, t) e)) = F.Lam x
                                 (transType d t)
                                 (\x' -> desugarExpr (d, Map.insert x (F.Var x x') g) e)
    go (L _ (BLam (a,_) e))    = F.BLam a (\a' -> desugarExpr (Map.insert a a' d, g) e)
    go (L _ LetIn{})         = panic "desugarExpr: LetIn"
    go (L _ (LetOut _ [] e))   = go e
    go (L _ (Merge e1 e2))     = F.Merge (go e1) (go e2)
    go (L _ (RecordCon fs))    =
      case fs of
        []       -> panic "desugarExpr: Record"
        [(l,e)]  -> F.RecordCon (l, go e)
        _        -> go (noLoc $ RecordCon (take (length fs - 1) fs)) `F.Merge` F.RecordCon (let (l,e) = last fs in (l,go e))
    go (L _ (RecordProj e l)) = F.RecordProj (go e) l
    go (L _ (RecordUpdate e fs)) =
      case fs of
        [] -> go e
        _  -> F.RecordUpdate (go (noLoc $ RecordUpdate e (take (length fs - 1) fs))) (let (l1,e1) = last fs in (l1, go e1))

    go (L _ (LetOut NonRec [(f1, _, e1)] e)) =
      -- F.App
      --   (F.Lam (transType d t1) (\f1' -> desugarExpr (d, Map.insert f1 (F.Var f1') g) e))
      --   (go e1)
      F.Let f1 (go e1) (\f1' -> desugarExpr (d, Map.insert f1 (F.Var f1 f1') g) e)

{-
Note that rewriting simultaneous let expressions by nesting is wrong unless we do
variable renaming. An example:

# let x = 1 in let x = 2 and y = x in y;;
- : int = 1

# let x = 1 in let x = 2 in let y = x in y;;
- : int = 2

   let f1 = e1, ..., fn = en in e
~> let y = (t1, ..., tn). (e1, ..., en) in e[*]
-}
    go (L _ (LetOut NonRec bs@(_:_) e)) =
      F.Let (intercalate "_" fs)
        (go tupled_es)
        (\y -> desugarExpr (d, g' y `Map.union` g) e)
        where
          (fs, _, es)  = unzip3 bs

          tupled_es = noLoc $ TupleCon es

          -- Substitution: fi -> y._(i-1)
          g' y = Map.fromList $ -- `Map.fromList` is right-biased.
                   zipWith (\f i -> (f, F.Proj i (F.Var f y)))
                           fs
                           [1..length bs]

{-
   let f : forall A1...An. t1 -> t2 = e@(\(x : t1). peeled_e) in body
                                      ^
Inside the marked e, f is polymorphic.

~> let f = /\A1...An. (fix f (x1 : t1) : t2. peeled_e) in body
                                             ^
However, f no longer is polymorphic inside peeled_e as the type variables A1...An has
been instantiated. If inside the original e, f is instantiated with different sets of
type variables, then after this rewriting the expression no longer typechecks.

Conclusion: this rewriting cannot allow type variables in the RHS of the binding.

~> (\(f : forall A1...An. t1 -> t2). body)
     (/\A1...An. fix y (x1 : t1) : t2. peeled_e)
-}
    go (L _ (LetOut Rec [(f,t@(Fun _ _),e)] body)) = desugarLetRecToLetRec (d,g) (noLoc $ LetOut Rec [(f,t,e)] body)
    go (L _ (LetOut Rec [(f,t,e)] body))          = desugarLetRecToLetRec (d,g) (noLoc $ LetOut Rec [(f,t,e)] body)
    go (L _ (LetOut Rec bs body))                 = desugarLetRecToLetRec (d,g) (noLoc $ LetOut Rec bs body)
    go (L _ (JNew c args))             = F.JNew c (map go args)
    go (L _ (JMethod callee m args r)) = F.JMethod (fmap go callee) m (map go args) r
    go (L _ (JField  callee f r))      = F.JField  (fmap go callee) f (transType d r)

    -- Non Java Class translation
    -- go (PrimList l)              = FPrimList (map go l)

    -- Primitive List to java class

    go (L _ (Error ty str))            = F.Error (transType d ty) (go str)

    go (L _ (Seq es)) = F.Seq (map go es)
    go (L _ (Data recflag databinds e)) = F.Data recflag (map (desugarDatabind d) databinds) (go e)

    go (L _ (ConstrOut c es)) = F.ConstrOut (desugarConstructor d c) (map go es)
    go (L _ (Case e alts)) = decisionTree (d,g) [e] pats exprs (replicate (length alts) [])
                     where pats = [ [pat] | ConstrAlt pat _ <- alts]
                           exprs = [ expr | ConstrAlt _ expr <- alts]
    go (L _ (CaseString e alts)) =
            let emptytest = noLoc $ JMethod (NonStatic e) "isEmpty" [] "java.lang.Boolean"
                [ConstrAlt _ b1, ConstrAlt (PConstr _ [sub1, sub2]) b2] = alts
                headfetch = noLoc $ JMethod (NonStatic e) "charAt" [noLoc $ Lit (Int 0)] "java.lang.Character"
                tailfetch = noLoc $ JMethod (NonStatic e) "substring" [noLoc $ Lit (Int 1)] "java.lang.String"
                b2'  = case sub1 of PVar nam _ -> noLoc $ LetOut NonRec [(nam, JClass "java.lang.Character", headfetch)] b2
                                    _ -> b2
                b2'' = case sub2 of PVar nam _ -> noLoc $ LetOut NonRec [(nam, JClass "java.lang.String", tailfetch)] b2'
                                    _ -> b2'
            in
            go (noLoc $ If emptytest b1 b2'')


desugarBindsToDefs :: (TVarMap t, VarMap t e) -> [Definition] -> F.Definition t e
desugarBindsToDefs _ [] = F.Null
desugarBindsToDefs (d, g) (b:bs) =
  case b of
    Def (n, t, e) -> F.Def n (t, transType d t) (desugarExpr (d, g) e)
                       (\f -> desugarBindsToDefs (d, Map.insert n (F.Var n f) g) bs)
    -- at least one element
    DefRec binds -> F.DefRec names types exprs def
      where (ids, sigs, defs) = unzip3 binds
            names = ids
            types = map (\t -> (t, transType d t)) sigs
            exprs ids' = map (desugarExpr (d, zipWith (\f f' -> (f, F.Var f f')) ids ids' `addToVarMap` g)) defs
            def ids' = desugarBindsToDefs (d, zipWith (\f f' -> (f, F.Var f f')) ids ids' `addToVarMap` g) bs

desugarLetRecToFix :: (TVarMap t, VarMap t e) -> CheckedExpr -> F.Expr t e
desugarLetRecToFix (d,g) (L _ (LetOut Rec [(f,t,e)] body)) =
  F.App
      (F.Lam f
          (transType d t)
          (\f' -> desugarExpr (d, addToEnv [(f, F.Var f f')] g) body))
      (F.Fix f x1
          (\f' x1' -> desugarExpr (d, addToEnv [(f, F.Var f f'), (x1, F.Var x1 x1')] g) peeled_e)
          (transType d t1)
          (transType d t2))
          where
            addToEnv binds g0 = foldr (\(x,x') acc -> Map.insert x x' acc) g0 binds -- TODO: subsumed
            (Just (x1, t1), t2, peeled_e) = peel Nothing (unLoc e,t)
              where
                peel Nothing (Lam (L _ x0, t0) b, Fun _ ret_ty) = (Just (x0,t0), ret_ty, b)
                peel _ (e,t) = prettyPanic "desugarLetRecToFix: not a function" (text (show e))
desugarLetRecToFix _ _ = panic "desugarLetRecToFix"

{-
    let rec f1 = e1, ..., fn = en in e
~>  let y = fix y (dummy : Int) : (t1, ..., tn). (e1, ..., en)[*] in e[*]
~>  (\(y : Int -> (t1, ..., tn)). e[*])
      (fix y (dummy : Int) : (t1, ..., tn). (e1, ..., en)[*])
-}
desugarLetRecToFixEncoded :: (TVarMap t, VarMap t e) -> CheckedExpr -> F.Expr t e
desugarLetRecToFixEncoded (d,g) = go
  where
    go (L _ (LetOut Rec bs@(_:_) e)) =
      F.App
          (F.Lam "_"
              (F.Fun (F.JClass "java.lang.Integer") (transType d tupled_ts))
              (\y -> desugarExpr (d, g' y `Map.union` g) e))
          (F.Fix "_" "_"
              -- Names ignored. Unused.
              (\y _dummy -> desugarExpr (d, g' y `Map.union` g) tupled_es)
              (F.JClass "java.lang.Integer")
              (transType d tupled_ts))
              where
                (fs, ts, es) = unzip3 bs

                tupled_es = noLoc $ TupleCon es
                tupled_ts = TupleType ts

                -- Substitution: fi -> (y 0)._(i-1)
                g' y = Map.fromList $ -- `Map.fromList` is right-biased.
                         zipWith
                             -- TODO: better var name
                           (\f i -> (f, F.Proj i (F.App (F.Var f y) (F.Lit (Int 0)))))
                           fs
                           [1..length bs]
    go _ = panic "desugarLetRecEncode"

-- Convert from: LetOut RecFlag [(Name, Type, CheckedExpr)] (CheckedExpr)
-- To:           LetRec [Type t] ([e] -> [Expr t e]) ([e] -> Expr t e)
desugarLetRecToLetRec :: (TVarMap t, VarMap t e) -> CheckedExpr -> F.Expr t e
desugarLetRecToLetRec (d,g) (L _ (LetOut Rec binds@(_:_) body)) = F.LetRec names' sigs' binds' body'
  where
    (ids, sigs, defs) = unzip3 binds
    names'            = ids
    sigs'             = map (transType d) sigs
    binds' ids'       = map (desugarExpr (d, zipWith (\f f' -> (f, F.Var f f')) ids ids' `addToVarMap` g)) defs
    body'  ids'       = desugarExpr (d, zipWith (\f f' -> (f, F.Var f f')) ids ids' `addToVarMap` g) body

desugarLetRecToLetRec _ _ = panic "desugarLetRecToLetRec"

-- DataBind -> F.DataBind
desugarDatabind ::  TVarMap t -> DataBind -> F.DataBind t
desugarDatabind d = go
  where go (DataBind n params ctrs) =
               F.DataBind n params (\t ->
                  let d' = addToTVarMap (zip params t) d
                  in  map (desugarConstructor d') ctrs
               )

-- Constructor -> F.Constructor
desugarConstructor :: TVarMap t -> Constructor -> F.Constructor t
desugarConstructor d' = go
  where go (Constructor n ts) = F.Constructor n (map (transType d') ts)

{-
 - given: case var of Cons x (Cons y z) -> expr
 - result: case var of
 -           Cons -> case (Cons)var.field2 of
 -                      Cons -> let x = (Cons)var.field1
 -                              let y = (Cons)((Cons)var.field2).field1
 -                              let z = (Cons)((Cons)var.field2).field2
 -                              expr
 -}

decisionTree ::  (TVarMap t, VarMap t e) -> [CheckedExpr] -> [[Pattern]] -> [CheckedExpr] -> [[(Name, Type, LExpr (Name,Type) Type)]] -> F.Expr t e
decisionTree (d,g) = go
  where -- no pattern left. Then the first expr will be the result
        go [] _ branches binds = desugarExpr (d,g) $ noLoc $ LetOut NonRec (head binds) (head branches)
        go exprs pats branches binds
          | all isWildcardOrVar patshead =
               go (tail exprs)
                  (map tail pats)
                  branches
                  (zipWith (\pat bind -> case head pat of
                               PVar nam ty -> (nam, ty, curExp'):bind
                               _ -> bind )
                           pats
                           binds)
          | null missingconstrs = F.Case (desugarExpr (d,g) curExp') (map makeNewAltFromCtr appearconstrs)
          | otherwise            = F.Case (desugarExpr (d,g) curExp') (map makeNewAltFromCtr appearconstrs ++ makeDefault)
          where patshead = map head pats
                curExp' = head exprs
                (appearconstrs, missingconstrs) = constrInfo patshead
                makeNewAltFromCtr ctr@(Constructor name params) =
                       let len = length params - 1
                           Datatype dtnam _ _ = last params
                           ctrclass = '$': dtnam ++ ".$" ++ dtnam ++ '$':name
                           curExp = noLoc $ JMethod (NonStatic (noLoc $ JField (Static ctrclass) "class" (JClass $ "Class<" ++ ctrclass++ ">")))
                                                    "cast" [curExp'] ctrclass
                           javafieldexprs = zipWith (\num pam -> noLoc $ JField (NonStatic curExp) (fieldtag ++ show num) pam)
                                                    [1..len]
                                                    params
                           exprs' = javafieldexprs ++ tail exprs
                           (pats', branches', binds') =
                               unzip3 $ foldr (\(curPattern:rest, branch, bind) acc ->
                                                  let nextPats = extractorsubpattern name len curPattern ++ rest
                                                  in  case curPattern of
                                                       PWildcard -> ( nextPats, branch, bind) :acc
                                                       PVar nam ty -> (nextPats, branch, (nam, ty, curExp): bind) :acc
                                                       PConstr (Constructor nam _) _
                                                           | nam /= name -> acc
                                                           | otherwise -> (nextPats, branch, bind):acc)
                                             []
                                             (zip3 pats branches binds)
                       in F.ConstrAlt (desugarConstructor d ctr) (go exprs' pats' branches' binds')
                makeDefault =
                       let (pats', branches', binds') =
                               unzip3 $ foldr (\(curPattern:rest, branch, bind) acc ->
                                                  case curPattern of
                                                     PWildcard -> (rest , branch, bind) :acc
                                                     PVar nam ty -> (rest, branch, (nam, ty, curExp'): bind) :acc
                                                     _ -> acc)
                                             []
                                             (zip3 pats branches binds)
                       in [F.Default $ go (tail exprs) pats' branches' binds']

addToVarMap :: [(Name, F.Expr t e)] -> VarMap t e -> VarMap t e
addToVarMap xs var_map = foldr (\(x,x') acc -> Map.insert x x' acc) var_map xs

addToTVarMap :: [(Name, t)] -> TVarMap t -> TVarMap t
addToTVarMap xs tvar_map = foldr (\(x,x') acc -> Map.insert x x' acc) tvar_map xs


<|start_filename|>frontend/Z3Backend.hs<|end_filename|>
{- |
Module      :  Z3Backend
Description :  The Z3 backend for symbolic
Copyright   :  (c) 2014—2015 The F2J Project Developers (given in AUTHORS.txt)
License     :  BSD3

Maintainer  :  <NAME> <<EMAIL>>
Stability   :  unstable
Portability :  portable

Symbolic evaluator will generates all possible execution paths for a given program. We use Z3 to kick out those infeasible execution paths.
-}

module Z3Backend where

import           Control.Monad
import           Control.Monad.IO.Class       (liftIO)
import qualified Data.IntMap                  as IntMap
import           Data.Map                     (Map, fromList)
import qualified Data.Map                     as Map
import           Data.Maybe                   (fromJust)
import           Prelude                      hiding (EQ, GT, LT)
import           PrettyUtils
import qualified Src                          as S
import           SymbolicEvaluator
import qualified SystemFI                     as FI
import           Text.PrettyPrint.ANSI.Leijen
import           Z3.Monad                     hiding (Z3Env)
import           Z3ModelParser

data Z3Env = Z3Env { index             :: Int
                   , boolSort, intSort :: Sort
                   , constrDecls       :: Map.Map String FuncDecl
                   , adtSorts          :: Map.Map String Sort
                   , symVars           :: IntMap.IntMap AST
                   , funVars           :: IntMap.IntMap FuncDecl
                   , target            :: Doc -> SymValue -> Z3 ()
                   }

explore, counter :: Int -> FI.Expr () ExecutionTree -> IO ()
explore = traverse defaultTarget
counter = traverse counterTarget

-- Collcet and declare all datatype definitions in the expression
declareAllDatatypes :: Z3Env -> FI.Expr () ExecutionTree -> [Z3 (String, Sort)]
declareAllDatatypes env = go
    where tree = Exp $ SBool True
          trees = repeat tree
      --  go (Data Rec databinds e1) = concatMap databinds ++ go e1
          go (FI.Data S.NonRec [databind] e1) = declareDatatype env 0 databind : go e1
          go (FI.If e1 e2 e3) = go e1 ++ go e2 ++ go e3
          go (FI.PrimOp e1 _ e2) = go e1 ++ go e2
          go (FI.Let _ e f) = go e ++ go (f tree)
          go (FI.TApp e1 _) = go e1
          go (FI.App e1 e2) = go e1 ++ go e2
          go (FI.ConstrOut _ es) = concatMap go es
          go (FI.Case e1 alts) = go e1 ++ concatMap (\(FI.ConstrAlt _ _ f) -> go (f trees)) alts
          go (FI.Lam _ _ e) = go (e tree)
          go (FI.BLam _ e) = go (e ())
          go (FI.Fix _ _ f _ _) = go (f tree tree)
          go (FI.LetRec _ _ binds body) = concatMap go (binds trees) ++ go (body trees)
          go _ = []

-- Declare a datatype, e.g. List: mkDatatype "List" [Nil, Cons]
declareDatatype :: Z3Env -> Int -> FI.DataBind () -> Z3 (String, Sort)
declareDatatype env recFlag (FI.DataBind name _ cs) =
    do sym <- mkStringSymbol name
       constrs <- mapM (declareConstructor env recFlag . transConstructor) (cs $ repeat ())
       sort <- mkDatatype sym constrs
       -- mapM_ delConstructor constrs
       return (name, sort)

-- Declare a constructor, e.g. Cons: mkConstructor "Cons" "isCons" [("Cons_1", Just intSort, 0), ("Cons_2", Nothing, 0)]
declareConstructor :: Z3Env -> Int -> SConstructor -> Z3 Constructor
declareConstructor env recFlag (SConstructor name types datatype) =
    do constr_sym <- mkStringSymbol name
       recognizer_sym <- mkStringSymbol ("is" ++ name)
       param_syms <- mapM (\i -> mkStringSymbol $ name ++ "_" ++ show i) [1..length types]
       let param_triples = zipWith (\sym t -> if t == datatype
                                              then (sym, Nothing, recFlag)
                                              else (sym, Just $ type2sort env t, recFlag))
                           param_syms
                           types
       mkConstructor constr_sym recognizer_sym param_triples

-- Given a datatype sort, returns a list of constructor name and its funcdecl pair
getAdtConstrNameDeclPairs :: Sort -> Z3 [(String, FuncDecl)]
getAdtConstrNameDeclPairs adtSort =
    do decls <- getDatatypeSortConstructors adtSort
       mapM pairWithName decls

    where pairWithName decl =
              do name <- getSymbolString =<< getDeclName decl
                 return (name, decl)

traverse :: (Int -> Doc -> SymValue -> Z3 ())
         -> Int
         -> FI.Expr () ExecutionTree
         -> IO ()
traverse target stop e =
    evalZ3 $ do
      int <- mkIntSort
      bool <- mkBoolSort
      -- tvar <- mkStringSymbol "T" >>= mkUninterpretedSort -- for type parameters

      let (tree, i) = exec $ seval e -- i is the # of symbolic values
      let env = Z3Env { index = i
                      , intSort = int, boolSort = bool--, tvarSort = tvar
                      , adtSorts = Map.empty
                      , constrDecls = Map.empty
                      , symVars = IntMap.empty
                      , funVars = IntMap.empty
                      , target = target i
                      }
      name_sort_pairs <- sequence (declareAllDatatypes env e)
      constr_decls <- foldM (\acc sort ->
                                     do pairs <- getAdtConstrNameDeclPairs sort
                                        return $ Map.fromList pairs `Map.union` acc)
                       Map.empty
                      (map snd name_sort_pairs)
      let env' = env { adtSorts = Map.fromList name_sort_pairs, constrDecls = constr_decls }
      pathsZ3 env' tree [] stop

defaultTarget :: Int -> Doc -> SymValue -> Z3 ()
defaultTarget _ cond e = liftIO $ putDoc $ cond <+> evalTo <+> pretty e <> linebreak

counterTarget :: Int -> Doc -> SymValue -> Z3 ()
counterTarget i cond (SBool False) =
    do liftIO $ putDoc $ cond <+> evalTo <+> text "False" <> linebreak
       withModel ((>>= (liftIO . putStrLn . counterExample i)) . showModel)
       return ()
counterTarget _ _ _ = return ()

pathsZ3 :: Z3Env -> ExecutionTree -> [Doc] -> Int -> Z3 ()
pathsZ3 _ _ _ stop | stop <= 0 = return ()
pathsZ3 env (Exp e) conds _ =
    target env (foldr1 combineWithAnd conds') e
    where conds' = reverse $ case conds of
                               [] -> conds ++ [text "True"] -- sole result
                               _ -> conds

pathsZ3 env (NewSymVar i typ t) conds stop =
    do ast <- declareVar env i typ
       let env' = either
                  (\x -> env{symVars = IntMap.insert i x (symVars env)})
                  (\x -> env{funVars = IntMap.insert i x (funVars env)})
                  ast
       pathsZ3 env' t conds stop

pathsZ3 env (Fork e (Left (l,r))) conds stop =
    do ast <- assertProjs env e
       local $ assert ast >> whenSat (re l (pretty e : conds) (stop-1))
       local $ mkNot ast >>= assert >> whenSat (re r (prependNot (pretty e) : conds) (stop-1))
    where re = pathsZ3 env

pathsZ3 env (Fork e@(SConstr c vs) (Right ts)) conds stop =
    do let (cs, _, fs) = unzip3 ts
           f = fromJust $ lookup (sconstrName c) (map sconstrName cs `zip` fs)
       _ <- assertProjs env e
       pathsZ3 env (f $ map Exp vs) conds stop
pathsZ3 env (Fork e (Right ts)) conds stop =
    do ast <- assertProjs env e
       mapM_ (local . assertConstructor ast) ts

    where assertConstructor :: AST -> (SConstructor, [S.Name], [ExecutionTree] -> ExecutionTree) -> Z3 ()
          assertConstructor node (SConstructor name types _, vars, f) =
              let constr_decl = constrDecls env Map.! name
                  var_sorts = map (type2sort env) types
                  next_index = index env + length vars
                  var_ids = [index env .. next_index - 1]
              in do var_id_ast_pairs <- zipWithM declareVarSort var_sorts var_ids
                    let var_asts = map snd var_id_ast_pairs
                        env' = env { index = next_index, symVars = IntMap.fromList var_id_ast_pairs `IntMap.union` symVars env  }
                        cond = pretty e <+> equals <+> hsep (map text $ name : map (("x"++) . show) var_ids)

                    assert =<< mkEq node =<< mkApp constr_decl var_asts
                    whenSat $ pathsZ3 env' (f $ supply (repeat "x") var_ids) (cond : conds) (stop-1)

type2sort :: Z3Env -> SymType -> Sort
type2sort env TBool = boolSort env
type2sort _ (TFun _ _) = error "type2sort: Function type"
type2sort env (TData name) = fromJust $ Map.lookup name $ adtSorts env
-- type2sort env _ = tvarSort env
type2sort env _ = intSort env
-- type2sort env TInt = intSort env

declareVar :: Z3Env -> Int -> SymType -> Z3 (Either AST FuncDecl)
declareVar env i (TFun tArgs tRes) =
    fmap Right (declareSymFun i (map (type2sort env) tArgs) (type2sort env tRes))
declareVar env i typ = fmap (Left . snd) $ declareVarSort (type2sort env typ) i

declareVarSort :: Sort -> Int -> Z3 (Int, AST)
declareVarSort s n =
    do x <- mkIntSymbol n
       c <- mkConst x s
       return (n, c)

declareSymFun :: Int -> [Sort] -> Sort -> Z3 FuncDecl
declareSymFun i args res =
    do f <- mkIntSymbol i
       mkFuncDecl f args res

-- assertProj :: AST -> (FuncDecl, AST) -> Z3 ()
-- assertProj app (f, arg) =
--     do ast <- mkApp f [app] >>= mkEq arg
--        assert ast

assertProjs :: Z3Env -> SymValue -> Z3 AST
assertProjs Z3Env {intSort = int, symVars = vars, funVars = funs, constrDecls = constrs} = go
    where go (SConstr c vs) =
              do asts <- mapM go vs
                 let decl = constrs Map.! sconstrName c
                 mkApp decl asts
          go (SVar _ i _) = return $ vars IntMap.! i
          go (SInt i) = mkInt (fromInteger i) int
          go (SBool True) = mkTrue
          go (SBool False) = mkFalse
          go (SOp op v1 v2) =
              do x1 <- go v1
                 x2 <- go v2
                 case op of
                   ADD -> mkAdd [x1, x2]
                   SUB -> mkSub [x1, x2]
                   MUL -> mkMul [x1, x2]
                   OR -> mkOr [x1, x2]
                   AND -> mkAnd [x1, x2]
                   DIV -> mkDiv x1 x2
                   LT -> mkLt x1 x2
                   LE -> mkLe x1 x2
                   GT -> mkGt x1 x2
                   GE -> mkGe x1 x2
                   EQ -> mkEq x1 x2
                   NEQ -> do ast <- mkEq x1 x2
                             mkNot ast
          go (SApp v1 v2) = symFun v1 [v2]
          go (SFun{}) = error "symValueZ3 of SFun"

          symFun :: SymValue -> [SymValue] -> Z3 AST
          symFun (SApp v1 v2) vs = symFun v1 (v2:vs)
          symFun (SVar _ i _) vs =
              do args <- mapM go vs
                 let f = funs IntMap.! i
                 mkApp f args
          symFun _ _ = error "symFun"

whenSat :: Z3 () -> Z3 ()
whenSat m =
    do b <- fmap res2bool check
       when b m

res2bool :: Result -> Bool
res2bool Sat = True
res2bool Unsat = False
res2bool Undef = error "res2bool: Undef"


<|start_filename|>testsuite/TestTerms.hs<|end_filename|>
module TestTerms where

import qualified Src as S
import Core

import Language.Java.Syntax as J (Op(..))

import Prelude hiding (const)

-- mu loop. \x -> loop x
loopStr = "fix loop. \\(x : Int). loop x : Int -> Int"
loop = fix (\loop x -> App (var loop) (var x)) (JClass "java.lang.Integer") (JClass "java.lang.Integer")

factStr = "fix fact. \\(n : Int). if n == 0 then 1 else n * fact (n-1) : Int"
fact = fix (\fact n ->
    If (PrimOp (var n) (S.Compare J.Equal) (Lit (S.Int 0)))
        (Lit (S.Int 1))
        (PrimOp (var n) (S.Arith J.Mult) (App (var fact) (PrimOp (var n) (S.Arith J.Sub) (Lit (S.Int 1))))))
    (JClass "java.lang.Integer") (JClass "java.lang.Integer")

tfact = fix (\fact n -> lam (JClass "java.lang.Integer") (\acc ->
    If (PrimOp (var n) (S.Compare J.Equal) (Lit (S.Int 0)))
        (var acc)
        (App (App (var fact) (PrimOp (var n) (S.Arith J.Sub) (Lit (S.Int 1)))) (PrimOp (var n) (S.Arith J.Mult) (var acc)))))
    (JClass "java.lang.Integer") (Fun (JClass "java.lang.Integer") (JClass "java.lang.Integer"))

fiboStr = "fix fibo. \\(n : Int). if0 n then 1 else (fibo (n-1)) + (fibo (n-2)) : Int"
fibo = fix (\fibo n ->
    If (PrimOp (var n) (S.Compare J.Equal) (Lit (S.Int 2)))
        (Lit (S.Int 1))
        (If (PrimOp (var n) (S.Compare J.Equal) (Lit (S.Int 1)))
             (Lit (S.Int 1))
             (PrimOp (App (var fibo) (PrimOp (var n) (S.Arith J.Sub) (Lit (S.Int 1)))) (S.Arith J.Add) (App (var fibo) (PrimOp (var n) (S.Arith J.Sub) (Lit (S.Int 2)))))))
    (JClass "java.lang.Integer") (JClass "java.lang.Integer")

factApp = App fact (Lit (S.Int 10))

fiboApp = App fibo (Lit (S.Int 10))
-- /\A. \(x:A) . x

idF1Str = "/\\A. \\(x:A). x"
idF = bLam (\a -> lam (tVar a) (\x -> var x))

-- /\A . (\(f : A -> A) . \(x : A) . f x) (idF A)

idF2Str = "/\\A. (\\(f : A -> A). \\(x : A). f x) (idF A)"
idF2 = bLam (\a -> App (lam (Fun (tVar a) (tVar a)) (\f -> lam (tVar a) (\x -> App (var f) (var x)))) (TApp idF (tVar a)))

-- /\A . \(x:A) . (idF A) x

idF3Str = "/\\A . \\(x:A) . (idF A) x"
idF3 = bLam (\a -> lam (tVar a) (\x -> App (TApp idF (tVar a)) (var x) ))

notailStr = "/\\A. \\(f : A -> (A -> A)). \\(g : A -> A). \\(x : A). (f x) (g x)"
notail =
  bLam (\a ->
    lam (Fun (tVar a) (Fun (tVar a) (tVar a))) (\f ->
      lam (Fun (tVar a) (tVar a)) (\g ->
        lam (tVar a) (\x ->
          App (App (var f) (var x)) (App (var g) (var x)) ))))

constStr = "/\\A . \\(x : A) . \\(y : A) . x"
const =
  bLam (\a ->
    lam (tVar a) (\x ->
       lam (tVar a) (\y ->
          var x
       )
    )
  )

-- /\A . \(x : A) . (/\A . \(f : A -> A -> A) . \(g : A -> A) . \(x : A) . f x (g x)) A (const A) (idF A) x
-- /\A . \(x : A) . notail A (const A) (idF A) x
program1 =
  bLam (\a ->
    lam (tVar a) (\x ->
       App (App (App (TApp notail (tVar a)) (TApp const (tVar a))) (TApp idF (tVar a))) (var x)
    )
  )

program1Num = App (TApp program1 (JClass "java.lang.Integer")) (Lit (S.Int 5))

-- should infer (forall (x0 : int) . int)
intapp = TApp idF (JClass "java.lang.Integer")


notail2Str = "/\\A. \\(f : A -> (A -> A)). \\(x : A). \\(y : A). (f x) ((f y) y)"
notail2 =
  bLam (\a ->
    lam (Fun (tVar a) (Fun (tVar a) (tVar a))) (\f ->
      lam (tVar a) (\x ->
        lam (tVar a) (\y ->
          App (App (var f) (var x)) (App (App (var f) (var y)) (var y)) ))))


program2 = App (App (App (TApp notail2 (JClass "java.lang.Integer")) (TApp const (JClass "java.lang.Integer"))) (Lit (S.Int 5))) (Lit (S.Int 6))

idfNum = App (TApp idF (JClass "java.lang.Integer")) (Lit (S.Int 10))

constNum = App (App (TApp const (JClass "java.lang.Integer")) (Lit (S.Int 10))) (Lit (S.Int 20))

notail3Str = "/\\A. \\(f : A -> (A -> A)). \\(g : A -> (A -> A)). \\(x : A). \\(y : A). (f x) ((g y) y)"
notail3 =
  bLam (\a ->
    lam (Fun (tVar a) (Fun (tVar a) (tVar a))) (\f ->
      lam (Fun (tVar a) (Fun (tVar a) (tVar a))) (\g ->
        lam (tVar a) (\x ->
          lam (tVar a) (\y ->
            App (App (var f) (var x)) (App (App (var g) (var y)) (var y)) )))))

program3 = App (App (App (App (TApp notail3 (JClass "java.lang.Integer")) (TApp const (JClass "java.lang.Integer"))) (TApp const (JClass "java.lang.Integer"))) (Lit (S.Int 5))) (Lit (S.Int 6))

notail4Str = "/\\A. \\(g : ((A -> A) -> (A -> A)) -> A). \\(f : A -> (A -> A)). \\(x : A). \\(y : A). (g (f x)) (f y)"
notail4 =
  bLam (\a ->
    lam ( Fun (Fun (tVar a) (tVar a)) (Fun (Fun (tVar a) (tVar a)) (tVar a))) (\g ->
      lam (Fun (tVar a) (Fun (tVar a) (tVar a))) (\f ->
        lam (tVar a) (\x ->
          lam (tVar a) (\y ->
            App (App (var g) (App (var f) (var x))) (App (var f) (var y)))))))

summaStr= "\\(x : Int -> Int). \\(y : Int -> Int). (x 0) + (y 0)"
summa =
    lam (Fun (JClass "java.lang.Integer") (JClass "java.lang.Integer")) (\x ->
       lam (Fun (JClass "java.lang.Integer") (JClass "java.lang.Integer")) (\y ->
          PrimOp (App (var x) (Lit (S.Int 0))) (S.Arith J.Add) (App (var y) (Lit (S.Int 0)))
       )
    )

program4 = App (App (App (App (TApp notail4 (JClass "java.lang.Integer")) summa) (TApp const (JClass "java.lang.Integer"))) (Lit (S.Int 5))) (Lit (S.Int 6))

evenOdd :: String
evenOdd = "let rec even = \\n -> n == 0 || odd (n-1) and odd = \\n -> if n == 0 then 0 else even (n-1) in odd"


<|start_filename|>frontend/Lab.hs<|end_filename|>
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-imports -fno-warn-unused-matches #-}

module Lab where

import qualified Src
import qualified Core
import Parser

import System.Directory

filePath = "examples/declaration_syntax/EvenOdd.sf"

main = do source <- readFile filePath
          print (parseProgram source)


<|start_filename|>frontend/Delazy.hs<|end_filename|>
-- Elaborating System F with mixed evaluation strategies (call-by-name /
-- call-by-value) to that with call-by-value strategy.

{-# LANGUAGE TypeOperators, FlexibleInstances, MultiParamTypeClasses #-}
{-# OPTIONS_GHC -Wall #-}

module Delazy
  ( EvaluationStrategy(..)
  , delazy
  ) where

import Core
import qualified Src as S

import Mixin

import Control.Monad (zipWithM)
import Unsafe.Coerce (unsafeCoerce)

data EvaluationStrategy = CallByValue | CallByName

delazy :: EvaluationStrategy -> Expr t e -> Expr t e
delazy _ = id

transTypeS :: Index -> TypeS Index -> TypeS Index
transTypeS i (Strict t) = Strict (transType i t)
transTypeS i (Lazy   t) = Strict (Fun (Strict UnitType) (transType i t))

transType :: Index -> Type Index -> Type Index
transType _ (TVar n a)       = TVar n a
transType _ (JClass c)       = JClass c
transType i (Fun t1 t2)      = Fun (transTypeS i t1) (transType i t2)
transType i (Forall n f)     = Forall n (\a -> transType (i + 1) $ fsubstTT i (TVar "" a) (f i))
transType i (Product ts)     = Product (map (transType i) ts)
transType _  UnitType        = UnitType

infer':: Class ((Type Index -> TypeS Index) -> Index -> Index -> Expr Index (Index, TypeS Index) -> TypeS Index)
infer' _    s _ _ (Var (_,t))         = t
infer' _    s _ _ (Lit (S.Integer _)) = s (JClass "java.lang.Integer")
infer' _    s _ _ (Lit (S.String _))  = s (JClass "java.lang.String")
infer' _    s _ _ (Lit (S.Boolean _)) = s (JClass "java.lang.Boolean")
infer' _    s _ _ (Lit (S.Char _))    = s (JClass "java.lang.Character")
infer' _    s _ _ (Lit  S.Unit)       = s UnitType
infer' this s i j (Lam t f)           = s $ Fun t (this s i (j+1) (f (j,t)))
infer' this s i j (BLam n f)          = Forall n (\a -> fsubstTT i (TVar "" a) $  $ this s (i+1) j (f i))
infer' _    s _ _ (Fix _ _ _ t1 t)    = Fun t1 t
infer' this s i j (Let b e)           = this s i (j+1) (e (j, this s i j b))
infer' this s i j (LetRec _ ts _ e)     = this s i (j+n) (e (zip [j..j+n-1] (map s ts))) where n = length ts
infer' this s i j (App f _)           = s $ t12 where Fun _ t12 = this s i j f
infer' this s i j (TApp f t)          = s $ joinType ((unsafeCoerce g :: t -> Type t) t) where Forall n g  = this i j f
infer' this s i j (If _ b1 _)         = this s i j b1
infer' _    s _ _ (PrimOp _ op _)     = s $ case op of S.Arith _   -> JClass "java.lang.Integer"
                                                       S.Compare _ -> JClass "java.lang.Boolean"
                                                       S.Logic _   -> JClass "java.lang.Boolean"
infer' this s i j (Tuple es)          = s $ Product (map (this s i j) es)
infer' this s i j (Proj index e)      = s $ ts !! (index-1) where Product ts = this s i j e
infer' _    s _ _ (JNew c _)          = s $ JClass c
infer' _    s _ _ (JMethod _ _ _ c)   = s $ JClass c
infer' _    s _ _ (JField _ _ c)      = s $ JClass c
infer' this s i j (Seq es)            = this i j (last es)

infer :: Index -> Index -> Expr Index (Index, TypeS Index) -> TypeS Index
infer = new infer'

instance (Type Index, Expr Index Index) <: Type Index where
  up = fst

transExpr'
  :: (Index -> Index -> Expr Index (Index, Type Index) -> Type Index)
  -> (Index -> Index -> Expr Index (Index, Type Index) -> (Type Int, Expr Index Index))
  -> Index  -> Index -> Expr Index (Index, Type Index) -> Expr Index Index
transExpr' _ _    _ _ (Var (x,_))       = Var x
transExpr' _ _    _ _ (Lit l)           = Lit l
transExpr' _ this i j (Lam t f)         = Lam (transTypeS i t) (\x -> fsubstEE j (Var x) body') where (_, body') = this i (j+1) (f (j, unS t))
transExpr' _ this i j (BLam n f)        = BLam n (\a -> fsubstTE i (TVar "" a) body')               where (_, body') = this (i+1) j (f i)
transExpr' _ this i j (Fix n1 n2 f t1 t)      = Fix n1 n2 (\x x1 -> (fsubstEE j (Var x) . fsubstEE (j+1) (Var x1)) body') t1' t'
  where
    (_, body') = this i (j+2) (f (j, Fun t1 t) (j+1, unS t1))
    t1'        = transTypeS i t1
    t'         = transType i t
transExpr' super this i j (Let b e) = Let b' (\x -> fsubstEE j (Var x) (snd (this i (j+1) (e (j, super i j b)))))
  where
    (_,b') = this i j b
transExpr' _     this i j (LetRec ns ts bs e) = LetRec ns' ts' bs' e'
  where
    ts'           = map (transType i) ts
    ns'           = ns
    bs'           = \fs' -> map (subst fs fs') bs_body'
    e'            = \fs' -> subst fs fs' e_body'
    (_, bs_body') = unzip (map (transExpr i (j+n)) (bs fs_with_ts))
    (_, e_body')  = this i (j+n) (e fs_with_ts)
    fs            = [j..j+n-1]
    fs_with_ts    = zip fs ts
    n             = length ts
    subst :: [Index] -> [Index] -> Expr Index Index -> Expr Index Index
    subst xs rs   = foldl (.) id [fsubstEE x (Var (rs !! k)) | (x,k) <- zip xs [0..n-1]]
transExpr' _ this i j (App e1 e2) = App e1 e2
transExpr' _ this i j (TApp e t)                   = TApp (snd (this i j e)) (transType i t)
transExpr' _ this i j (If p b1 b2)                 = If (snd (this i j p)) (snd (this i j b1)) (snd (this i j b2))
transExpr' _ this i j (PrimOp e1 op e2)            = PrimOp (snd (this i j e1)) op (snd (this i j e2))
transExpr' _ this i j (Tuple es)                   = Tuple (snd (unzip (map (this i j) es)))
transExpr' _ this i j (Proj index e)               = Proj index (snd (this i j e))
transExpr' _ this i j (JNew c es)                  = JNew c (snd (unzip (map (this i j) es)))
transExpr' _ this i j (JMethod callee m args ret)  = JMethod (fmap (snd . this i j) callee) m (snd (unzip (map (this i j) args))) ret
transExpr' _ this i j (JField callee m ret)        = JField (fmap (snd . this i j) callee) m ret
transExpr' _ this i j (Seq es)                     = Seq (snd (unzip (map (this i j) es)))

transExpr :: Index -> Index -> Expr Index (Index, Type Index) -> (Type Index, Expr Index Index)
transExpr = new (infer' `with` transExpr'')
  where
    transExpr'' :: Mixin
      (Index -> Index -> Expr Index (Index, Type Index) -> Type Index)
      (Index -> Index -> Expr Index (Index, Type Index) -> (Type Index, Expr Index Index))
    transExpr'' super this i j e  = (super i j e, transExpr' super this i j e)


<|start_filename|>runtime/src/f2j/unbox/ClosureBoxBox.java<|end_filename|>
package f2j.unbox;

public abstract class ClosureBoxBox implements Closure
{
  public Object arg;
  public Object res;
  public boolean hasApply = true;
  public abstract void apply ();
  public ClosureBoxBox clone () {
      return (ClosureBoxBox) ((Object) this.clone());
  }
}


<|start_filename|>examples/case_studies/FOLogic.hs<|end_filename|>
{-# LANGUAGE TemplateHaskell #-}

module FOLogic where

{-
To simplify, the following structrues are not contained in this First order logic.
1 The Term do not contain function, namely, we do not have "P(f(x,y))", things like that
2 Every predicate can only have one arguement, we do not have P(x,y)
3 The domain of constant is just [1..1000]
4 The domain of identity is just ["o".."z"]
5 The domain of predicate is just ["O".."Z"]
6 We assume that the context is given, that is, we already know the relation between predicates
  and constants
----all the constrain of the model is kind to quickCheck.

and
1 Try "runTests" to test all the properties
2 Try "multiTestCl" to test "prop_theCl", the Clever version, 10 times
3 Try "multiTestNv" to test "prop_theNv", the Naive version, 10 times

-}


import Test.QuickCheck
import Test.QuickCheck.All
import qualified Data.Set as Set
import MonadLib
import Data.Char as C
import System.CPUTime
import System.Timeout
import qualified Data.Foldable


--type definition

type Pre = String
type Ide = String
type Cos = Int

data Term = Var Ide | Con Cos deriving (Show,Eq)

data FOrmula = Prd Pre Term        --only one arguement predicates involved
               | And FOrmula FOrmula
               | Or FOrmula FOrmula
               | Implies FOrmula FOrmula
               | Not FOrmula
               | E Ide FOrmula
               | A Ide FOrmula deriving (Show,Eq)

data Assigment = Asg Ide Cos deriving (Show,Eq)

type Valuation = [Assigment]


-- context  (the properties that every constants hold)----------
data Convention = Prop Pre [Cos] deriving (Show,Eq)
type Context = [Convention]

-------------a construction of a random context-------------
--try "context" to see the content of it

predicate = map (:[]) ['O'..'Z']
constant  = [1..36]

change :: [Int] -> Int -> [Int]
change [] x = []
change (c:cs) x = if (c `mod` 12) == x then c:(change cs x) else change cs x

helper = map (change [1..36]) [0..12]

multiconstant :: Int -> [Int] -> [[Int]]
multiconstant 0 c = [c]
multiconstant i c = c:(multiconstant (i-1) c)

context = zipWith Prop predicate helper
--------------------------------------------------------------

--getCon for Term
getCon (Con c) = c


--getfunction for Valuation
getConsV :: Valuation -> [Cos]
getConsV []               = []
getConsV ((Asg i1 c1):vs) = c1:(getConsV vs)

getIde :: Valuation -> [Ide]
getIde []               = []
getIde ((Asg i1 c1):vs) = i1:(getIde vs)

--getfunction for Assigment
getIdeA (Asg i _) = i
getCosA (Asg _ c) = c

--getfuntion for Convention
getPreC :: Convention -> Pre
getPreC (Prop p _) = p

getCosC :: Convention -> [Cos]
getCosC (Prop _ cc) = cc

showCons :: String -> Context -> [Cos]
showCons p (c1:cs) = if p == getPreC c1 then getCosC c1
                                        else showCons p cs

-----Navie generator------------------
instance Arbitrary Assigment where
 arbitrary = liftM2 Asg (elements (map (:[]) ['o'..'z'])) (elements [1..36])



----------clever generator------------
uniqueVal :: Valuation -> Valuation
uniqueVal va@(v@(Asg i c):vs) = if elem i (getIde vs) then uniqueVal vs
                                                      else v:(uniqueVal vs)
uniqueVal _ = []

clGen :: Gen Valuation
clGen = fmap uniqueVal xyzArb
        where xyzArb = liftM2 (:) (liftM2 Asg (return "x") (elements [1..36]))
                      (liftM2 (:) (liftM2 Asg (return "y") (elements [1..36]))
                      (liftM2 (:) (liftM2 Asg (return "z") (elements [1..36])) arbitrary))


---------------------------------------

--the statement & property (whether the statement is true under all valuations) & counterexample
the = Implies (A "x" (Or (Prd "P" (Var "x")) (Prd "Q" (Var "x")))) (Or (A "y" (Prd "P" (Var "y"))) (A "z" (Prd "Q" (Var "z"))))

prop_theNv :: Valuation -> Property
prop_theNv v = ((vars the) `Set.isSubsetOf` (Set.fromList (map getIdeA (uniqueVal v)))) ==>
                                  satisfy (pf the) (uniqueVal v)

prop_theCl :: Property
prop_theCl = forAll clGen $ \v -> satisfy (pf the) (uniqueVal v)

counterExample = [(Asg "x" 1), (Asg "y" 1), (Asg "z" 2), (Asg "r" 2)]

----------------------------------------


---------------------------prenex normal form----------------------------------------

--function "simplify"  (erase the implies and eat the not)
simplify :: FOrmula -> FOrmula
simplify (Prd p v)           = Prd p v
simplify (And l r)           = And (simplify l) (simplify r)
simplify (Or l r)            = Or (simplify l) (simplify r)
simplify (Implies l r)       = Or (Not (simplify l)) (simplify r)
simplify (Not (E i f))       = A i (simplify (Not f))
simplify (Not (A i f))       = E i (simplify (Not f))
simplify (Not (And l r))     = Or (simplify (Not l)) (simplify (Not r))
simplify (Not (Or l r))      = And (simplify (Not l)) (simplify (Not r))
simplify (Not (Implies l r)) = And (simplify l) (simplify (Not r))
simplify (Not f)             = Not (simplify f)
simplify (E i f)             = E i (simplify f)
simplify (A i f)             = A i (simplify f)


--function "isSimplified"
isSimplified :: FOrmula -> Bool
isSimplified (Prd p v)       = True
isSimplified (And l r)       = isSimplified l && isSimplified r
isSimplified (Or l r)        = isSimplified l && isSimplified r
isSimplified (Implies l r)   = False
isSimplified (Not (Prd _ _)) = True
isSimplified (Not _)         = False
isSimplified (E i f)         = isSimplified f
isSimplified (A i f)         = isSimplified f



--function "opf" (prenex form for one step) (outmost)
opf :: FOrmula -> FOrmula
opf (Prd p v)       = Prd p v
opf (And (A i f) r) = A i (And f (opf r))
opf (And l (A i f)) = A i (And (opf l) f)
opf (And (E i f) r) = E i (And f (opf r))
opf (And l (E i f)) = E i (And (opf l) f)
opf (And l r)       = And (opf l) (opf r)
opf (Or (A i f) r)  = A i (Or f (opf r))
opf (Or l (A i f))  = A i (Or (opf l) f)
opf (Or (E i f) r)  = E i (Or f (opf r))
opf (Or l (E i f))  = E i (Or (opf l) f)
opf (Or l r)        = Or (opf l) (opf r)
opf (Not (Prd p v)) = Not (Prd p v)
opf (Not f)         = opf (simplify (Not f))
opf (Implies l r)   = opf (simplify (Implies l r))
opf (A i f)         = A i (opf f)
opf (E i f)         = E i (opf f)


--function "lgh"    somehow like the lenght of a formula
lgh :: FOrmula -> Int
lgh (Prd p v) = 1
lgh (And l r) = (lgh l) + (lgh r)
lgh (Or l r) = (lgh l) + (lgh r)
lgh (Implies l r) = (lgh l) + (lgh r)
lgh (Not f) = lgh f
lgh (E i f) = lgh f
lgh (A i f) = lgh f


--function "pf"
pf :: FOrmula -> FOrmula
pf f = pfhelp f (lgh f)

pfhelp :: FOrmula -> Int -> FOrmula
pfhelp f 0 = f
pfhelp f n = pfhelp (opf f) (n-1)
---------------------------------------------------------------------------



------------------------------satisfy---------------------------------------
--function "vars"
vars :: FOrmula -> Set.Set Ide
vars (E i f)        = Set.singleton i `Set.union` vars f
vars (A i f)        = Set.singleton i `Set.union` vars f
vars (Prd p t) =
        case t of Var v -> Set.singleton v
                  Con c -> Set.empty
vars (Not f)        = vars f
vars (And l r)      = vars l `Set.union` vars r
vars (Or l r)       = vars l `Set.union` vars r
vars (Implies l r)  = vars l `Set.union` vars r

--function "prdof" get the predicate used in a FOrmula
prdof :: FOrmula -> Set.Set Pre
prdof (Prd p _)     = Set.singleton p
prdof (E i f)       = prdof f
prdof (A i f)       = prdof f
prdof (Not f)       = prdof f
prdof (And l r)     = prdof l `Set.union` prdof r
prdof (Or l r)      = prdof l `Set.union` prdof r
prdof (Implies l r) = prdof l `Set.union` prdof r



--function "verify" verify a FOrmula without variables, with context
verify :: FOrmula -> Bool
verify (Prd p c)     = if (elem p predicate) then elem (getCon c) (showCons p context)
                                             else False
verify (Not f)       = not (verify f)
verify (Or l r)      = verify l || verify r
verify (And l r)     = verify l && verify r
verify (Implies l r) = (not (verify l)) || verify r






--function "iequivalent" give the list of i-equivalent valuation of a valuation
iequivalent :: Valuation -> Ide -> [Valuation]
iequivalent v@((Asg i1 c1):vs) i = map (:(deleteIE v i)) (map (Asg i) (getConsV v))

--deleteIE
deleteIE :: Valuation -> Ide -> Valuation
deleteIE (v@(Asg i1 c1):vs) i = if i == i1 then vs
                                           else v:(deleteIE vs i)


--function "satisfy"
satisfy :: FOrmula -> Valuation -> Bool
satisfy f [] = if Set.null (vars f)
               then verify f
               else error "the valuation is not exhuasted."
satisfy f va = if (vars f) `Set.isSubsetOf` (Set.fromList (map getIdeA va))
               then case f of
                Prd p fo    -> verify $ Prd p (subst fo va)
                And l r     -> satisfy l va && satisfy r va
                Or l r      -> satisfy l va || satisfy r va
                Implies l r -> (not (satisfy l va)) || satisfy r va
                Not f       -> not (satisfy f va)
                A i fo -> foldl (&&) True (map (satisfy fo) (iequivalent va i))
                E i fo -> foldl (||) False (map (satisfy fo) (iequivalent va i))
               else error "the valuation is not exhuasted."

--function "subst" valua the constants into variables
subst :: Term -> Valuation -> Term
subst t va@(v:vs) =  case t of
                           Var t1 -> if t1 == (getIdeA v) then Con (getCosA v) else subst t vs
                           Con t1 -> Con t1


------------------------------------------------------------------------------------------


-----------------------------------timer--------------------------------------------------

timeIt :: (Fractional c) => (a -> IO b) -> a -> IO c
timeIt action arg = do
       startTime <- getCPUTime
       action arg
       finishTime <- getCPUTime
       return $ fromIntegral (finishTime - startTime)  / 1000000000

--timeIt' :: (Fractional c) => (a -> b) -> a -> IO c
--timeIt' f = timeIt (\x -> f x `seq` return())

oneTestNv = timeout 5000000 $ timeIt quickCheck prop_theNv >>= print --change prop here
oneTestCl = timeout 5000000 $ timeIt quickCheck prop_theCl >>= print --change prop here

multiTestNv = do
            startTime <- getCPUTime
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000

multiTestCl = do
            startTime <- getCPUTime
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000


-----------------------------------------------------------------------------------------


------for-quickCheck-test-------
return []                     --
runTests = $quickCheckAll     --
--------------------------------







<|start_filename|>runtime/src/f2j/TypeHouse.java<|end_filename|>
package f2j;

public class TypeHouse
{
    public String typeOf;
    void TypeHouse(String str) {
        typeOf = str;
    }
}


<|start_filename|>examples/fractals/lib/Complex.java<|end_filename|>
package lib;

public class Complex {
    public static Complex ZERO = new Complex(0, 0);

    private double x, y;

    public Complex(double x, double y) {
        this.x = x;
        this.y = y;
    }

    public Complex add(Complex a) {
        return new Complex(x + a.x, y + a.y);
    }

    public Complex multiply(Complex a) {
        return new Complex(x * a.x - y * a.y, y * a.x + x * a.y);
    }

    public Complex sqr() {
        return multiply(this);
    }

    public double magnitude() {
        return Math.sqrt(x * x + y * y);
    }

    public Complex abs() {
        return new Complex(Math.abs(x), Math.abs(y));
    }
}



<|start_filename|>runtime/src/f2j/FileServer.java<|end_filename|>
package f2j;

import java.util.*;
import java.lang.*;
import java.io.*;
import javax.tools.*;
import java.net.*;
import java.lang.reflect.*;

public class FileServer {

    public final static int FILE_SIZE = 1022386;

    public static void compile(String fileName, String cp)
    {
        // Save source in .java file.
        File sourceFile = new File(fileName);

        // Compile source file.
        JavaCompiler compiler = ToolProvider.getSystemJavaCompiler();

        DiagnosticCollector <JavaFileObject> diagnostics =
            new DiagnosticCollector<JavaFileObject>();
        StandardJavaFileManager fileManager =
            compiler.getStandardFileManager(diagnostics, null, null);
        File [] files = new File [] {sourceFile};
        Iterable<? extends JavaFileObject> compilationUnits =
            fileManager.getJavaFileObjectsFromFiles(Arrays.asList(files));

        String [] compileOptions = new String[] {"-classpath", cp};
        Iterable<String> compilationOptions = Arrays.asList(compileOptions);

        JavaCompiler.CompilationTask task =
        compiler.getTask(null, fileManager, diagnostics, compilationOptions,
                         null, compilationUnits);
        task.call();
    }

    public static String compileLoad (String fileName, String cp)
      throws InvocationTargetException,
             ClassNotFoundException,
             NoSuchMethodException,
             IllegalAccessException
    {
        compile(fileName,cp);

        String className = "";
        int i = 0;
        while(fileName.charAt(i) != '.') {
            className += fileName.charAt(i);
            i++;
        }

        ClassLoader classLoader = FileServer.class.getClassLoader();
        // Dynamically load class and invoke its main method.
        try {
            //Class<?> cls = Class.forName(className);
            Class<?> cls = classLoader.loadClass(className);
            Method meth = cls.getMethod("main", String[].class);
            String[] params = null;

          try {
            meth.setAccessible(true);
            meth.invoke(null, (Object) params);
          } catch (InvocationTargetException e) {
            System.out.println(e + ": " + e.getCause());
          }
        } catch (ClassNotFoundException e1) {
          System.out.println(e1 + ": " + e1.getCause());
        } catch (NoSuchMethodException e2) {
          System.out.println(e2 + ": " + e2.getCause());
        } catch (IllegalAccessException e3) {
          System.out.println(e3 + ": " + e3.getCause());
        }
        System.out.println("exit");

        return className;
    }

    public static void DeleteDummy()
    {
      File dir = new File(".");
      File fList[] = dir.listFiles();

      for(File f : fList) {
        if(f.getName().endsWith(".class")
           && !f.getName().startsWith("FileServer")
           && !f.getName().startsWith("TypeServer"))
          f.delete();
      }
    }

    public static void main (String [] args)
    {
        Scanner scanner = new Scanner(System.in);
        String cp = args[0];

        while(true){
          if(!scanner.hasNextLine()) break;

          String fileName = scanner.nextLine();

          //Receive .java file from client
          try {
            File myFile = new File(fileName);
            BufferedWriter output = new BufferedWriter(new FileWriter(myFile));

            while (scanner.hasNextLine()) {
              String line = scanner.nextLine();
              if(line.equals("//end of file")) break;
              output.write(line);
              }
              output.close();
              String className = compileLoad(fileName,cp);
              myFile.delete();
          } catch (Exception e) {
            e.printStackTrace();
          }

          // Delete dummy .class files in current directory
          DeleteDummy();
        }
    }

}


<|start_filename|>frontend/Link.hs<|end_filename|>
module Link where

import System.FilePath (dropExtension)
import Data.Char
import Data.List.Split (splitOn)
import Data.List

link :: FilePath -> String -> IO ()
link file mod = do
  --let list = lines mod
  --let contM = concatenate (take ((length list) - 1) list)
  content <- readFile file
  let contF = namespace content
  let newFile = (dropExtension file) ++ "c.sf"
  --writeFile newFile ("let\n" ++ contM ++ "in\n")
  writeFile newFile mod
  appendFile newFile contF

linkModule :: [FilePath] -> IO String
linkModule [] = return ""
linkModule (x:xs) = do
  contM <- readFile x
  --let content = breakLine contM (dropExtension x)
  rest <- linkModule xs
  --return (content ++ rest)
  return (contM ++ rest)

breakLine :: String -> String -> String
breakLine content name = let list = lines content in addByLine list name

addByLine :: [String] -> String -> String
addByLine [] _ = ""
addByLine (x:xs) name = name ++ "_" ++ x ++ "\nand\n" ++ (addByLine xs name)

concatenate :: [String] -> String
concatenate [] = ""
concatenate (x:xs) = x ++ "\n" ++ concatenate xs

namespace :: String -> String
namespace x = let ys = lines x in (unlines . replaceDot) ys

replaceDot :: [String] -> [String]
replaceDot [] = []
replaceDot (x:xs) =
  let func = unwords . map checkDot in func (words x) : replaceDot xs

-- Allow datatype to be wrapped in ()
checkDot :: String -> String
checkDot x =
  if length xs <= 1
    then x
    else let (y1:y2:ys) = xs in
           if (isUpper $ (y1 !! 0)) && (isUpper $ (y2 !! 0)) ||
               ((y1 !! 0) == '(' && (isUpper $ (y1 !! 1)))
           then y1 ++ "_" ++ y2 ++ (intercalate "." ys)
           else x
  where xs = splitOn "." x

test :: FilePath -> IO String
test file = do
  content <- readFile file
  return $ namespace content


<|start_filename|>examples/case_studies/PureLambda.hs<|end_filename|>
{-# LANGUAGE TemplateHaskell #-}

module PureLambda
       (Ide,
        LambdaCalculus,
        TermA(..),
        TermL(..),
        freeVars,
        fullForm,
        lgh,
        limitedReduce,
        simpleForm,
        allWords) where

import Data.Maybe (fromJust)
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Test.QuickCheck.All
import Test.QuickCheck
import Control.Monad
import System.CPUTime
import System.Timeout


type Ide            = String
data TermL          = Var Ide | App TermL TermL | Abs Ide TermL deriving Eq -- lambda term
data TermA          = Asg Ide TermL deriving Eq                             -- assignment term
type LambdaCalculus = Either TermL TermA


instance Arbitrary TermL where
 arbitrary = sized arbTermL

arbTermL 0 = liftM Var (elements initc)
arbTermL n = frequency [
             (1, (liftM Var (elements initc))),
             (3, (liftM2 App (arbTermL (n `div` 2))
                             (arbTermL (n `div` 2)))),
             (3, (liftM2 Abs (elements initc)
                             (arbTermL (n `div` 2)))) ]


initc :: [String]
initc = map (: []) ['a'..'z']

----------

absOpr  = "."
absHead = "\\"
appOpr  = " "

fullForm :: TermL -> String
fullForm (Var x)         = x
fullForm (Abs x y)       = "(" ++ absHead ++ x ++ absOpr ++ fullForm y ++ ")"
fullForm (App x y)       = "(" ++ fullForm x ++ appOpr ++ fullForm y ++ ")"

simpleForm :: TermL -> String
simpleForm (Var x)                = x
simpleForm (Abs x (Var y))        = absHead ++ x ++ absOpr ++ y
simpleForm (Abs x y)              = absHead ++ x ++ absOpr ++ simpleForm y
simpleForm (App x y)              = helper1 x ++ appOpr ++ helper2 y False
  where helper1 (Var a)           = a
        helper1 (App x y)         = helper1 x ++ appOpr ++ helper2 y True
        helper1 a                 = "(" ++ simpleForm a ++ ")"
        helper2 (Var a) _         = a
        helper2 a@(Abs _ _) False = simpleForm a
        helper2 a@(Abs _ _) True  = "(" ++ simpleForm a ++ ")"
        helper2 a _               = "(" ++ simpleForm a ++ ")"

instance Show TermL where
  show = simpleForm

instance Show TermA where
  show (Asg id t) = id ++ " = " ++ show t

-- Theory part

freeVars :: TermL -> Set Ide
freeVars (Var x)     = Set.singleton x
freeVars (App t1 t2) = freeVars t1 `Set.union` freeVars t2
freeVars (Abs x t)   = Set.delete x $ freeVars t

isClosed :: TermL -> Bool
isClosed = Set.null . freeVars


-----property: freeVars

subst :: TermL -> Ide -> TermL -> TermL      -- substitution first term substitute into Ide
subst n x m@(Var y)                         -- if y = x, then just subst n to y, otherwise m
  | x == y             = n
  | otherwise          = m
subst n x (App p q)    = App (subst n x p) (subst n x q)   -- App, subst each respectively
subst n x m@(Abs y p)                                      -- Abs,
  | x == y             = m                                 -- if it is bounded, no subst
  | x `Set.notMember` freeP  = m                           -- bounded in p, still no subst
  | y `Set.notMember` freeN  = Abs y (subst n x p)         -- then fv in n is still free
  | otherwise          = Abs z $ subst n x $ subst (Var z) y p --otherwise change y to z
  where freeP          = freeVars p
        freeN          = freeVars n
        freeNP         = freeP `Set.union` freeN
        z              = genNewIde freeNP

genNewIde :: Set Ide -> Ide                                --- get a new z
genNewIde ids = head $ filter (`Set.notMember` ids) allWords

allWords :: [String]
allWords            = concat $ iterate addPrefix initVars
  where addPrefix s = [a:b | a <- alphabet, b<-s]
        initVars    = map (: []) alphabet
        alphabet    = ['a'..'z']


----property : x would not appear in fv of m if it is subst "good and easy property"
prop_subst :: TermL -> Ide -> TermL -> Property
prop_subst n x m = x `Set.notMember` (freeVars n) ==> x `Set.notMember` (freeVars (subst n x m))



alphaCongruent :: TermL -> TermL -> Bool
alphaCongruent (Var x) (Var y)          = x == y
alphaCongruent (App x1 y1) (App x2 y2)  = alphaCongruent x1 x2 && alphaCongruent y1 y2
alphaCongruent (Abs x tx) (Abs y ty)
  | x == y                              = alphaCongruent tx ty
  | otherwise                           = alphaCongruent (subst (Var z) x tx) (subst (Var z) y ty)
  where z                               = genNewIde $ freeVars tx `Set.union` freeVars ty
alphaCongruent _ _                      = False

----property : alphaCon is reflexive, transitive, symtaxxx
prop_alphaCongruent_ref :: TermL -> Bool        --easy
prop_alphaCongruent_ref t = alphaCongruent t t

prop_alphaCongruent_traNv :: TermL -> TermL -> TermL -> Property
prop_alphaCongruent_traNv t1 t2 t3 =
    (alphaCongruent t1 t2) && (alphaCongruent t2 t3) ==> alphaCongruent t1 t3

prop_alphaCongruent_sym :: TermL -> TermL -> Property
prop_alphaCongruent_sym t1 t2 = alphaCongruent t1 t2 ==> alphaCongruent t2 t1


----property : alpha subst
prop_alphasubst :: TermL -> TermL -> TermL -> TermL -> Ide -> Property
prop_alphasubst m1 m2 n1 n2 x = (alphaCongruent m1 m2) && (alphaCongruent n1 n2) ==>
                                 alphaCongruent (subst n1 x m1) (subst n2 x m2)


-- Leftmost Outmost Reduce

loReduce :: TermL -> Maybe TermL        --just one step
loReduce (Var _) = Nothing
loReduce (App (Abs x t1) t2) = Just $ subst t2 x t1   --beta reduction
loReduce (App t1 t2) =
  case loReduce t1 of
    Just t1' -> Just $ App t1' t2        -- leftmost
    Nothing ->
      case loReduce t2 of
        Just t2' -> Just $ App t1 t2'    -- just as it has parens
        Nothing -> Nothing
loReduce (Abs x t) =
  case loReduce t of
    Just t' -> Just $ Abs x t'
    Nothing -> Nothing

lgh :: TermL -> Int                      -- number of Var
lgh (Var _)     = 1
lgh (App t1 t2) = lgh t1 + lgh t2
lgh (Abs _ t)   = 1 + lgh t


limitedReduce :: TermL -> [TermL]
limitedReduce x
  | length trace < steps = map fromJust trace
  | otherwise            = []
  where steps            = (lgh x)*2
        trace            = take steps . takeWhile (/=Nothing) . iterate (>>= loReduce) $ Just x
--take steps is a partial function


----property : P to be reduced to M and N, then exists T, such that can be reduced by both M, N
prop_limitedReduce :: TermL -> Bool
prop_limitedReduce p = allAlphaCon $ limitedReduce p


allAlphaCon :: [TermL] -> Bool
allAlphaCon [] = True
allAlphaCon [t] = True
allAlphaCon (x:xs@(y:ys)) = (alphaCongruent xl yl) && allAlphaCon xs
                              where xl = head $ reverse (limitedReduce x)
                                    yl = head $ reverse (limitedReduce y)

exhaustedIterate :: Eq a => (a -> a) -> a -> a  --till it deplicate it exhausted
exhaustedIterate f x   = helper trace
  where trace          = iterate f x
        helper (x:xs@(y:_))
          | x == y     = x
          | otherwise  = helper xs



----------------------------timer--------------------------------
timeIt :: (Fractional c) => (a -> IO b) -> a -> IO c
timeIt action arg = do
       startTime <- getCPUTime
       action arg
       finishTime <- getCPUTime
       return $ fromIntegral (finishTime - startTime)  / 1000000000

--timeIt' :: (Fractional c) => (a -> b) -> a -> IO c
--timeIt' f = timeIt (\x -> f x `seq` return())

oneTestNv = timeout 5000000 $ timeIt quickCheck prop_alphaCongruent_traNv >>= print
--oneTestCl = timeout 5000000 $ timeIt quickCheck prop_alphaCongruent_tra >>= print

multiTestNv = do
            startTime <- getCPUTime
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            oneTestNv
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000
{-
multiTestCl = do
            startTime <- getCPUTime
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            oneTestCl
            finishTime <- getCPUTime
            return $ fromIntegral (finishTime - startTime) / 1000000000
-}




------for-quickCheck-test------
return []                    --
runTests = $quickCheckAll    --
-------------------------------


<|start_filename|>examples/cps_knapsack/Makefile<|end_filename|>
all : cps_knapsack.sf
	f2j -r $^

.PHONY : clean
clean :
	rm -f *.class *.java


<|start_filename|>frontend/parse/Makefile<|end_filename|>
# Makefile for generating lexers and parsers

lexers  = Lexer.hs
parsers = Parser.hs
parserinfos = Parser.info

.PHONY : all
all : $(lexers) $(parsers)

# When compiling a grammar with GHC, the -g switch causes an even faster and
# smaller grammar to be generated.
$(lexers) : %.hs : %.x
	alex --ghc $<

$(parsers) : %.hs : %.y
	happy --info -agc $<

.PHONY : clean
clean :
	rm -f $(lexers) $(parsers) $(parserinfos)
