{-# LANGUAGE NamedFieldPuns #-}
{-
 Copyright (C) 2012-2017 Jimmy Liang, Michal Antkiewicz, Rafael Olaechea <http://gsd.uwaterloo.ca>

 Permission is hereby granted, free of charge, to any person obtaining a copy of
 this software and associated documentation files (the "Software"), to deal in
 the Software without restriction, including without limitation the rights to
 use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
 of the Software, and to permit persons to whom the Software is furnished to do
 so, subject to the following conditions:

 The above copyright notice and this permission notice shall be included in all
 copies or substantial portions of the Software.

 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 SOFTWARE.
-}
-- | Generates JS representation of IR for the <https://github.com/gsdlab/chocosolver Chocosolver>.
module Language.Clafer.Generator.Choco (genCModule) where

import Data.List
import qualified Data.Map as Map
import Language.Clafer.Common
import Language.Clafer.Front.LexClafer
import Language.Clafer.Generator.ChocoModel
import Language.Clafer.Intermediate.Intclafer

-- | Choco 3 code generation, with the given smallest and largest integers, if any, and the
--   number of fractional digits of decimals, if given
genCModule :: (IModule, GEnv) -> [(UID, Integer)] -> (Maybe Integer, Maybe Integer) -> Maybe Integer -> [Token] -> Result
genCModule ir scopes intRange decimalDigits otherTokens' = jsModel $ chocoModel ir scopes intRange decimalDigits otherTokens'

-- | The variable of a clafer: $ and its UID, e.g., $x for the clafer x, so that a clafer whose
--   name is a function of chocosolver's API (e.g., join) or a word of JavaScript does not
--   replace it.
jsVar :: UID -> String
jsVar = ('$' :)

-- | The variable of a local of a quantifier: $_ and its name, e.g., $_x for x, apart from the
--   clafers' variables (a name starts with a letter).
jsLocalVar :: String -> String
jsLocalVar = ("$_" ++)

-- | The clafers, then their supers, then their references, and then the constraints.
--   chocosolver checks a reference which refines an inherited one, e.g., @E1 : Edge -> N2@
--   under @abstract Edge -> Node ?@, when it reads it: the target must extend the inherited
--   target, and the super's reference must be known. So all the supers come before the
--   references, also those of the clafers declared further down, and the reference of a
--   super before those of its subclafers.
jsModel :: CModel -> Result
jsModel CModel{cmElements, cmScope, cmEscapes} =
    jsScope cmScope
    ++ "\n"
    ++ (jsClafer =<< cmElements)
    ++ (jsSuper =<< clafers)
    ++ (jsRef =<< sortOn superDepth clafers)
    ++ (jsLinks "root" =<< cmElements)
    ++ cmEscapes
  where
    clafers = allCClafers cmElements
    supers = Map.fromList [ (ccUid c, s) | c <- clafers, Just s <- [ccSuper c] ]
    superDepth = depth [] . ccUid
    depth visited uid' = case Map.lookup uid' supers of
      Just s | s `notElem` visited -> 1 + depth (s : visited) s
      _                            -> 0 :: Int

-- | The clafers, in pre-order
allCClafers :: [CElement] -> [CClafer]
allCClafers es = [ c' | CEClafer c <- es, c' <- c : allCClafers (ccElements c) ]

jsSuper :: CClafer -> Result
jsSuper CClafer{ccUid, ccLinked, ccSuper = Just super'} | ccLinked = jsVar ccUid ++ ".extending(" ++ jsVar super' ++ ");\n"
jsSuper _ = ""

jsRef :: CClafer -> Result
jsRef CClafer{ccUid, ccLinked, ccRef = Just ref'} | ccLinked = jsVar ccUid ++ refTo ref' ++ ";\n"
  where
    refTo (True, target)  = ".refToUnique(" ++ jsTarget target ++ ")"
    refTo (False, target) = ".refTo(" ++ jsTarget target ++ ")"
    jsTarget "integer" = "Int"
    jsTarget "int" = "Int"
    jsTarget "decimal" = "Decimal"
    jsTarget "string" = "string"
    jsTarget target = jsVar target
jsRef _ = ""

jsScope :: CScope -> Result
jsScope CScope{csClafers, csIntRange, csStringLength, csDecimalScale} =
    -- chocosolver looks the keys up as the clafers' variables
    (if null csClafers then "" else "scope({" ++ intercalate ", " [jsVar uid' ++ ":" ++ show scope | (uid', scope) <- csClafers] ++ "});\n")
    ++ "defaultScope(1);\n"
    ++ maybe "" (\(low, high) -> "intRange(" ++ show low ++ ", " ++ show high ++ ");\n") csIntRange
    ++ "stringLength(" ++ show csStringLength ++ ");\n"
    ++ maybe "" (\scale -> "decimalScale(" ++ show scale ++ ");\n") csDecimalScale

-- | The clafers, nested
jsClafer :: CElement -> Result
jsClafer (CEClafer CClafer{ccUid, ccParent, ccAbstract, ccCard, ccGCard, ccElements}) =
    jsVar ccUid
    ++ nesting
    ++ prop "withGroupCard" (jsCard ccGCard)
    ++ ";\n"
    ++ (jsClafer =<< ccElements)
  where
    nesting
        | ccAbstract && ccParent == "clafer" = " = Abstract(\"" ++ ccUid ++ "\")"
        | ccAbstract                         = " = " ++ jsVar ccParent ++ ".addAbstractChild(\"" ++ ccUid ++ "\")"
        | ccParent == "root"                 = " = Clafer(\"" ++ ccUid ++ "\")" ++ prop "withCard" (jsCard ccCard)
        | otherwise                          = " = " ++ jsVar ccParent ++ ".addChild(\"" ++ ccUid ++ "\")" ++ prop "withCard" (jsCard ccCard)
jsClafer _ = ""

-- | The constraints, objectives and assertions, in the context of a clafer
jsLinks :: String -> CElement -> Result
jsLinks _ (CEClafer CClafer{ccUid, ccLinked, ccRefConstraints, ccElements})
    | ccLinked =
        concatMap (\c -> jsVar ccUid ++ ".addConstraint(" ++ jsExp c ++ ");\n") ccRefConstraints
        ++ (jsLinks ccUid =<< ccElements)
    | otherwise = jsLinks ccUid =<< ccElements
jsLinks "root" (CEConstraint e) = "Constraint(" ++ jsExp e ++ ");\n"
jsLinks pUID (CEConstraint e) = jsVar pUID ++ ".addConstraint(" ++ jsExp e ++ ");\n"
jsLinks _ (CEAssert e) = "assert(" ++ jsExp e ++ ");\n"
jsLinks _ (CEObjective True e) = "max(" ++ jsExp e ++ ");\n"
jsLinks _ (CEObjective False e) = "min(" ++ jsExp e ++ ");\n"

prop :: String -> Maybe String -> String
prop name = maybe "" (\value -> "." ++ name ++ "(" ++ value ++ ")")

jsCard :: Maybe Interval -> Maybe String
jsCard (Just (low, -1))   = Just $ show low
jsCard (Just (low, high)) = Just $ show low ++ ", " ++ show high
jsCard Nothing            = Nothing

jsExp :: CExp -> String
jsExp CThis = "$this()"  -- this is a keyword in Javascript
jsExp (CGlobal u) = "global(" ++ jsVar u ++ ")"
jsExp (CName n) = jsLocalVar n
jsExp (CInt val) = "constant(" ++ show val ++ ")"
jsExp (CStr val) = "constant(" ++ show val ++ ")"
jsExp (CDouble val) = "constant(" ++ show val ++ ")"
jsExp (CDecimal val) = "decimal(\"" ++ val ++ "\")"
jsExp (CEmpty "Int") = "constant(Int)"
jsExp (CEmpty c) = "constant(" ++ jsVar c ++ ")"
jsExp (CJoin e c) = "join(" ++ jsExp e ++ ", " ++ jsVar c ++ ")"
jsExp (CJoinRef e) = "joinRef(" ++ jsExp e ++ ")"
jsExp (CJoinParent e) = "joinParent(" ++ jsExp e ++ ")"
jsExp (CFun f args') = f ++ "(" ++ intercalate ", " (map jsExp args') ++ ")"
jsExp (CQuant q [] body') = jsQuant q ++ "(" ++ jsExp body' ++ ")"
jsExp (CQuant q decls' body') =
    jsQuant q ++ "([" ++ intercalate ", " (map jsDecl decls') ++ "], " ++ jsExp body' ++ ")"
  where
    jsDecl (CDecl isDisj' locals body'') =
        (if isDisj' then "disjDecl" else "decl") ++ "([" ++ intercalate ", " (map jsLocal locals) ++ "], " ++ jsExp body'' ++ ")"
    jsLocal local = jsLocalVar local ++ " = local(\"" ++ local ++ "\")"

jsQuant :: IQuant -> String
jsQuant INo = "none"
jsQuant ISome = "some"
jsQuant IAll = "all"
jsQuant IOne = "one"
jsQuant ILone = "lone"