------------------------------------------------------------------
-- |
-- Module      : Gom.CodeGen.Strategies
-- Copyright   : (c) Paul Brauner 2009
--               (c) Emilie Balland 2009
--               (c) INRIA 2009
-- Licence     : GPL (see COPYING)
--
-- Maintainer  : paul.brauner@inria.fr
-- Stability   : provisional
-- Portability : non-portable (requires generalized newtype deriving)
--------------------------------------------------------------------

module Gom.CodeGen.Strategies (
  compStrategy
) where

import Gom.Sig
import Gom.FileGen
import Gom.SymbolTable
import Gom.CodeGen.Common

import Text.PrettyPrint.Leijen

-- | Given a sort @S@ of constructors @Ci@, 
-- generates the package @s@ containing the
-- @_Ci@ congruence classes.
compStrategy :: SortId -> Gen FileHierarchy
compStrategy s = do ctrs  <- askSt (sCtorsOf s)
                    cs <- mapM compCongruence ctrs
                    ms <- mapM compMake ctrs
                    is <- mapM compIs ctrs
                    return $ Package (show $ lowerId s) (cs++ms++is) 

-- | Given a non-variadic constructor @C@, 
-- generates a congruence strategy class @_C@.
compCongruence :: CtorId -> Gen FileHierarchy
compCongruence c = 
  do body <- vcat `fmap` sequence 
               [compStratConstructor (text "_") c,
                compVisitCongr c, 
                compVisitLightCongr c]
     return $ Class classname (wrap body)
  where wrap = rClass public (text classname) (Just jSCombinator) []
        classname = '_':show c

-- | Given a non-variadic constructor @C@,
-- generates the creation strategy class @Make_C@.
compMake :: CtorId -> Gen FileHierarchy
compMake c = do
  body <- vcat `fmap` sequence 
            [compStratConstructor (text "Make_") c,
             compVisitMake c, 
             compVisitLightMake c]
  return $ Class classname (wrap body)
  where wrap = rClass public (text classname) (Just jSCombinator) []
        classname = "Make_" ++ show c

-- | Given a non-variadic constructor @C@,
-- generates the test strategy class @Is_C@.
compIs :: CtorId -> Gen FileHierarchy
compIs c = do
  qc <- qualifiedCtor c
  return $ Class classname (wrap $ body qc)
  where wrap = rClass public (text classname) (Just jSCombinator) []
        classname = "Is_" ++ show c
        body qc = vcat $ map text
          ["private static final String msg = \"Not a " ++ show c ++"\";",
           "public Is_" ++ show c ++ "() {",
           "  initSubterm();",
           "}",
           "public <T> T visitLight(T __any, tom.library.sl.Introspector __i)",
           "  throws tom.library.sl.VisitFailure {",
           "  if(__any instanceof " ++ show qc ++ "){",
           "    return __any;",
           "  } else {",
           "    throw new tom.library.sl.VisitFailure(msg);",
           "  }",
           "}",
           "public int visit(tom.library.sl.Introspector __i) {",
           "  Object __any = environment.getSubject();",
           "  if(__any instanceof " ++ show qc ++ ") {",
           "    return tom.library.sl.Environment.SUCCESS;",
           "  } else {",
           "    return tom.library.sl.Environment.FAILURE;",
           "  }",
           "}"]

-- | Given a non-variadic constructor @C@, generates
-- the method @public int visit(Introspector introspector) { ... }@
-- for class @_C@.
compVisitCongr :: CtorId -> Gen Doc
compVisitCongr c = body `fmap` qualifiedCtor c
  where body qc = vcat $ map text 
          ["public int visit(tom.library.sl.Introspector __i) {",
           "  environment.setIntrospector(__i);",
           "  Object __any = environment.getSubject();",
           "  if (__any instanceof " ++ show qc ++ ") {",
           "    int childCount = __i.getChildCount(__any);",
           "    Object[] childs = null;",
           "    for(int i = 0; i < childCount; i++) {",
           "      Object oldChild = __i.getChildAt(__any,i);",
           "      environment.down(i+1);",
           "      int status = arguments[i].visit(__i);",
           "      if(status != tom.library.sl.Environment.SUCCESS) {",
           "        environment.upLocal();",
           "        return status;",
           "      }",
           "      Object newChild = environment.getSubject();",
           "      if(childs != null) {",
           "        childs[i] = newChild;",
           "      } else if(newChild != oldChild) {",
           "        // allocate the array, and fill it",
           "        childs = __i.getChildren(__any);",
           "        childs[i] = newChild;",
           "      } ",
           "      environment.upLocal();",
           "    }",
           "    if(childs!=null) {",
           "      environment.setSubject",
           "        (__i.setChildren(__any,childs));",
           "    }",
           "    return tom.library.sl.Environment.SUCCESS;",
           "  } else {",
           "    return tom.library.sl.Environment.FAILURE;",
           "  }",
           "}"]

-- | Given a non-variadic constructor @C@, generates
-- the method @public int visitLight(Introspector introspector) { ... }@
-- for class @_C@.
compVisitLightCongr :: CtorId -> Gen Doc
compVisitLightCongr c = do 
  n <- length `fmap` askSt (fieldsOf c)
  qc <- qualifiedCtor c
  return $ body qc n
  where body qc n = vcat $ map text 
          ["public <T> T visitLight(T __any,",
           "  tom.library.sl.Introspector __i)", 
           "  throws tom.library.sl.VisitFailure {",
           "  if(__any instanceof " ++ show qc ++ ") {",
           "    T result = __any;",
           "    Object[] childs = null;",
           "    for (int i = 0, nbi = 0; i < " ++ show n ++"; i++) {",
           "        Object oldChild = __i.getChildAt(__any,nbi);",
           "        Object newChild =",
           "           arguments[i].visitLight(oldChild,__i);",
           "        if(childs != null) {",
           "          childs[nbi] = newChild;",
           "        } else if(newChild != oldChild) {",
           "          // allocate the array, and fill it",
           "          childs = __i.getChildren(__any);",
           "          childs[nbi] = newChild;",
           "        }",
           "        nbi++;",
           "    }",
           "    if(childs!=null) {",
           "      result = __i.setChildren(__any,childs);",
           "    }",
           "    return result;",
           "  } else {",
           "    throw new tom.library.sl.VisitFailure();",
           "  }",
           "}"]

-- | Given a non-variadic constructor @C(_:T0,...,_:Tn)@, generates
-- > public int visit(tom.library.Introspector i) {
-- >   getChildAt(0).visit(i);
-- >   if (! (getEnvironment().getSubject() instanceof m.types.T0)) {
-- >     return tom.library.sl.Environment.FAILURE;
-- >   }
-- >   foo.types.T0 new_t0 = (foo.types.T0) getEnvironment().getSubject();
-- >
-- >   ...
-- >
-- >   getChildAt(n).visit(i);
-- >   if (! (getEnvironment().getSubject() instanceof m.types.Tn)) {
-- >     return tom.library.sl.Environment.FAILURE;
-- >   }
-- >   foo.types.Tn new_tn = (foo.types.Tn) getEnvironment().getSubject();
-- > 
-- >   getEnvironment().setSubject(m.types.co.C.make(new_t0, ..., new_tn));
-- >   return tom.library.sl.Environment.SUCCESS;
-- > }
compVisitMake :: CtorId -> Gen Doc
compVisitMake c = do
  qc  <- qualifiedCtor c
  ss  <- map snd `fmap` askSt (fieldsOf c)
  qss <- mapM myQualifiedSort ss
  let n = length qss
  return . method . vcat $ 
    (zipWith block qss [0..]) ++ [setSub qc n, lastLine]
  where myQualifiedSort s | isBuiltin s = return $ qualifiedBuiltin s
                          | otherwise = qualifiedSort s
        -- getChildAt(n) [...] = (foo.types.Tn) getEnvironment().getSubject()
        block qs i = vcat [getChild, testSort, assignTi]
          where getChild = cast (text "getChildAt" <> parens (int i))
                           <> text ".visit(__i);"
                testSort = rIfThen cond failure
                assignTi = qs <+> text "new_t" <> int i <+> equals <+> 
                           parens qs <+> text "getEnvironment().getSubject();"
                cond = text "!(getEnvironment().getSubject() instanceof "
                       <> qs <> text ")"
                failure = text "return tom.library.sl.Environment.FAILURE;"
                cast x = parens (parens jStrategy <+> x)
        -- getEnvironment().setSubject(m.types.co.C.make(new_t0, ..., new_tn))
        setSub qc n = rMethodCall (text "getEnvironment()") (text "setSubject")
                        [rMethodCall qc (text "make") ts] <> semi
          where ts = [text "new_t" <> int i | i <- [0..n-1]]
        lastLine = text "return tom.library.sl.Environment.SUCCESS;"
        method body = text "public int visit(tom.library.sl.Introspector __i)"
                      <+> ibraces body

-- | Given a non-variadic constructor @C(_:T0,...,_:Tn)@, generates
-- > public <T> T visitLight(T any, tom.library.Introspector i) 
-- >   throws tom.library.sl.VisitFailure {
-- >   Object tmp_t0 = ((tom.library.sl.Strategy) getChildAt(0)).visit(any,i);
-- >   if (!(tm_t0 instanceof m.types.T0)) {
-- >     throw new tom.library.sl.VisitFailure();
-- >   }
-- >   foo.types.T0 new_t0 = (foo.types.T0) tmp_t0;
-- >
-- >   ...
-- >
-- >   Object tmp_tn = ((tom.library.sl.Strategy) getChildAt(n)).visit(any,i);
-- >   if (!(tm_tn instanceof m.types.Tn)) {
-- >     throw new tom.library.sl.VisitFailure();
-- >   }
-- >   foo.types.Tn new_tn = (foo.types.Tn) tmp_tn;
-- > 
-- >   return (T) m.types.co.C.make(new_t0, ..., new_tn);
-- > }
compVisitLightMake :: CtorId -> Gen Doc
compVisitLightMake c = do
  qc  <- qualifiedCtor c
  ss  <- map snd `fmap` askSt (fieldsOf c)
  qss <- mapM myQualifiedSort ss
  let n = length qss
  return . method . vcat $ 
    (zipWith block qss [0..]) ++ [lastLine qc n]
  where myQualifiedSort s | isBuiltin s = return $ qualifiedBuiltin s
                          | otherwise = qualifiedSort s
        -- Object tmp_tn [...] = (foo.types.Tn) tmp_tn
        block qs i = vcat [visitChild, testSort, assignTi]
          where visitChild = text "Object" <+> tmp_i <+> equals <+>
                             cast (text "getChildAt" <> parens (int i))
                             <> text ".visit(__any,__i);"
                tmp_i    = text "__tmp_" <> int i
                testSort = rIfThen cond failure
                assignTi = qs <+> text "__new_t" <> int i <+> equals
                           <+> parens qs <+> tmp_i <> semi
                cond = text "!(" <> tmp_i <+> instanceof <+> qs <> text ")"
                failure = text "throw new tom.library.sl.VisitFailure();"
                cast x = parens (parens jStrategy <+> x)
        -- return (T) m.types.co.C.make(new_t0, ..., new_tn);
        lastLine qc n = text "return (T)" <+> 
                        rMethodCall qc (text "make") ts <> semi
          where ts = [text "__new_t" <> int i | i <- [0..n-1]]
        method body = (vcat $ map text 
                         ["public <T> T visitLight(T __any,",
                          "  tom.library.sl.Introspector __i)",
                          "  throws tom.library.sl.VisitFailure"]) 
                      <+> ibraces body
 
-- | Given a non-variadic constructor @C(x1,...,xn)@ 
-- and a prefix @prefix@, generates
--
-- >   public prefixf(tom.library.sl.Strategy s_x1, 
-- >                  ...,
-- >                  tom.library.sl.Strategy s_xn) {
-- >    this.initSubterm(
-- >      new tom.library.sl.Strategy[] { s_x1, ..., s_xn });
-- >  }
compStratConstructor :: Doc -> CtorId -> Gen Doc
compStratConstructor pr c = do
  fs <- map convert `fmap` askSt (fieldsOf c)
  return $ rMethodDef public empty (pr <> pretty c)
                      (map (jStrategy <+>) fs) (rBody [body fs])
  where convert = (text "__s_" <>) . pretty . fst
        body fs = rMethodCall this (text "initSubterm") [array]
          where array   = new <+> jStrategyArray <+> sbraces content 
                content = align $ sep (punctuate comma fs)