module Spicey.GenerationHelper where

import Data.Char

import AbstractCurry.Types
import AbstractCurry.Build
import Database.ERD
import Database.ERD.Goodies
import Data.Time

------------------------------------------------------------------------
-- lower the first character in a string
lowerFirst :: String -> String
lowerFirst (y:ys) = (toLower y) : ys
lowerFirst []     = [] -- this case should not occur, but one never knows...

-- upper the first character in a string
upperFirst :: String -> String
upperFirst (y:ys) = (toUpper y) : ys
upperFirst []     = [] -- this case should not occur, but one never knows...

------------------------------------------------------------------------
--- Qualify a string (module name) with the prefix `Model.`
model :: String -> String
model s = "Model." ++ s

--- Converts a string into a qualified name of the module
--- "Database.CDBI.Connection".
dbconn :: String -> QName
dbconn f = ("Database.CDBI.Connection", f)

--- Converts a string into a qualified name of the module "HTML.Base".
html :: String -> QName
html f = ("HTML.Base", f)

-- Some module names:
listModule :: String
listModule = "Data.List"

timeModule :: String
timeModule = "Data.Time"

spiceyModule :: String
spiceyModule = "System.Spicey"

authenticationModule :: String
authenticationModule = "System.Authentication"

-- Name of generic authorization module:
authorizationModule :: String
authorizationModule = "System.Authorization"

--- Converts a name into a qualified name of the module "HTML.Base".
htmlModule :: String -> QName
htmlModule n = ("HTML.Base", n)

--- Converts a name into a qualified name of the module "HTML.Session".
sessionModule :: String -> QName
sessionModule n = ("HTML.Session", n)

--- Converts a name into a qualified name of the module "Config.Storage".
storageModule :: String -> QName
storageModule n = ("Config.Storage", n)

--- Converts a name into a qualified name of the module "HTML.WUI".
wuiModule :: String -> QName
wuiModule n = ("HTML.WUI", n)

sessionInfoModule :: String
sessionInfoModule = "System.SessionInfo"

-- Type "UserSessionInfo"
userSessionInfoType :: CTypeExpr
userSessionInfoType = baseType (sessionInfoModule,"UserSessionInfo")

dataModuleName :: String
dataModuleName = "Config.RoutesData"

mappingModuleName :: String
mappingModuleName = "Config.ControllerMapping"

--- Name of EntitiesToHtml module.
entitiesToHtmlModule :: String -> String
entitiesToHtmlModule _ = "View.EntitiesToHtml"

bootstrapModule :: String
bootstrapModule = "HTML.Styles.Bootstrap4"

-- Name of hrefButton operation:
hrefButtonName :: QName
hrefButtonName = (bootstrapModule, "hrefPrimSmButton")

-- Name of hrefSmallButton operation:
hrefSmallButtonName :: QName
hrefSmallButtonName = (bootstrapModule, "hrefPrimBadge")

relatedRelation :: String -> Relationship -> String
relatedRelation en (Relationship _ [REnd en1 _ _, REnd en2 _ _]) =
  if en==en1 then en2 else en1

relationshipsForEntityName :: String -> [Relationship] -> [Relationship]
relationshipsForEntityName ename rels = filter endsIn rels
 where
  endsIn (Relationship _ ends) = any (\ (REnd n _ _) -> ename == n) ends

-- An entity is generated (to represent many-to-many relations)
-- if all attributes are foreign keys
isGenerated :: Entity -> Bool
isGenerated (Entity _ attrs) = null (filter (not . isForeignKey) attrs)

notPKey :: Attribute -> Bool
notPKey (Attribute _ _ k _) = k /= PKey

notKey :: Attribute -> Bool
notKey (Attribute _ t _ _) =
  case t of
    (KeyDom _) -> False
    _ -> True

-- An entity is relevant for a list of attributes if the first Key attribute
-- is a key to this entity.
isRelevantForEntity :: Entity -> [Attribute] -> Bool
isRelevantForEntity (Entity ename a) (attr:attrs) =
  case attr of
    (Attribute _ (KeyDom name) _ _) -> ename == name
    _ -> isRelevantForEntity (Entity ename a) attrs
isRelevantForEntity _ [] = False

oneToOne :: Entity -> [Relationship] -> [String]
oneToOne (Entity ename _) rel =
    map (relatedRelation ename) (filter isOneToOne rel)
 where
  isOneToOne :: Relationship -> Bool
  isOneToOne relationship = case relationship of
    Relationship _ [(REnd _ _ (Exactly 1)), (REnd _ _ (Exactly 1))] -> True
    _                                                               -> False

--- Returns for a given entities the many-to-one related entity names.
manyToOne :: Entity -> [Relationship] -> [String]
manyToOne (Entity ename _) rel =
    map (relatedRelation ename) (filter isManyToOne rel)    
 where
  isManyToOne :: Relationship -> Bool
  isManyToOne relationship = case relationship of
    Relationship _ [REnd _        _ (Exactly 1),
                    REnd relEName _ (Between _ _)] -> relEName == ename
    _                                              -> False

--- Returns for a given entity the many-to-many related entity names
--- together with the relation name.
manyToMany :: [Entity] -> Entity -> [(String,String)]
manyToMany entities forEntity =
  map (getOtherREnd forEntity)
      (filter (\ (Entity ename attr) -> isGenerated (Entity ename attr) &&
                                        isRelevantForEntity forEntity attr)
              entities)
 where
  getOtherREnd (Entity ename _)
               (Entity mmename [(Attribute _ (KeyDom name1) _ _),
                                (Attribute _ (KeyDom name2) _ _)]) =
    (if name1 == ename then name2 else name1, mmename)
      
--- The standard type of new and list controllers.
controllerType :: CTypeExpr
controllerType = baseType (spiceyModule,"Controller")

controllerModuleName :: String -> String
controllerModuleName entityName = "Controller." ++ entityName

--- The name of the type synonym for a "new entity" tuple.
newEntityTypeName :: String -> QName
newEntityTypeName entityName =
  (controllerModuleName entityName, "New" ++ entityName)
  
--- The name of the controller form for a given entity and form type.
controllerFormName :: String -> String -> QName
controllerFormName entityName formtype =
  (controllerModuleName entityName, formtype ++ entityName ++ "Form")

--- The name of the controller store for a given entity and store type.
controllerStoreName :: String -> String -> QName
controllerStoreName entityName storetype =
  (controllerModuleName entityName, storetype ++ entityName ++ "Store")

--- The name of the controller function for a given entity and controller
--- functionality.
controllerFunctionName :: String -> String -> QName
controllerFunctionName entityName controllerFunction =
  (controllerModuleName entityName,
   controllerFunction ++ entityName ++ "Controller")
  
--- The name of the transaction function for a given entity and transaction
--- functionality.
transFunctionName :: String -> String -> QName
transFunctionName entityName controllerFunction =
  (controllerModuleName entityName,
   controllerFunction ++ entityName ++ "T")
  
  
viewModuleName :: String -> String
viewModuleName entityName = "View." ++ entityName

viewFunctionName :: String -> String -> QName
viewFunctionName entityName viewFunction =
  (viewModuleName entityName, viewFunction ++ entityName ++ "View")

--- The type of view blocks, i.e., `[BaseHtml]`.
viewBlockType :: CTypeExpr
viewBlockType = listType (baseType (html "BaseHtml"))

-- Attach the type class `HTML` with type variable to a type expression.
withHTMLContext :: CTypeExpr -> CQualTypeExpr
withHTMLContext = CQualType (CContext [(html "HTML", htmlTVar)])

-- The type variable `h` used to `HTML` types in type expressions.
htmlTVar :: CTypeExpr
htmlTVar = CTVar (0,"h")

attrType :: Attribute -> CTypeExpr
attrType (Attribute _ t k False) =
  case t of (IntDom _)       -> if k==PKey 
                                then ctvar "Key" 
                                else ctvar "Int"
            (FloatDom _)     -> ctvar "Float"
            (StringDom _ )   -> ctvar "String"
            (BoolDom _)      -> ctvar "Bool"
            (DateDom _)      -> ctvar "ClockTime"
            (UserDefined s _)-> ctvar s
            (KeyDom _)       -> ctvar "Key"
            _                -> ctvar "Int"
attrType (Attribute _ t k True) = 
  case t of (IntDom _)       -> if k==PKey 
                                then maybeType (ctvar "Key")
                                else maybeType (ctvar "Int")
            (FloatDom _)     -> maybeType (ctvar "Float")
            (StringDom _ )   -> ctvar "String"
            (BoolDom _)      -> maybeType (ctvar "Bool")
            (DateDom _)      -> maybeType (ctvar "ClockTime")
            (UserDefined s _)-> maybeType (ctvar s)
            (KeyDom _)       -> maybeType (ctvar "Key")
            _                -> maybeType (ctvar "Int")

--- Generates Curry expressions representing default values.
--- The first argument contains an expression that is used for
--- ClockTime attributes (it is set to the current
--- time as a default value).
attrDefaultValues :: CExpr -> [Attribute] -> [CExpr]
attrDefaultValues defaultctime attrs = map defaultValue attrs
 where
  defaultValue (Attribute _ domain _ null) = case domain of
    IntDom    Nothing  -> nothingOrDefault
    IntDom    (Just n) -> addJust (CLit (CIntc n))
    FloatDom  Nothing  -> nothingOrDefault
    FloatDom  (Just x) -> addJust (CLit (CFloatc x))
    CharDom   Nothing  -> nothingOrDefault
    CharDom   (Just c) -> addJust (CLit (CCharc c))
    StringDom Nothing  -> string2ac "" -- null string values are empty strings
    StringDom (Just s) -> string2ac s
    BoolDom   Nothing  -> nothingOrDefault
    BoolDom   (Just b) -> addJust (constF (pre (if b then "True" else "False")))
    DateDom   Nothing  -> nothingOrDefault
    DateDom   (Just (CalendarTime y mo d h m s tz))
                       -> addJust (applyF (timeModule, "toClockTime")
                                    [applyF (timeModule, "CalendarTime")
                                      (map (CLit . CIntc) [y,mo,d,h,m,s,tz])])
    UserDefined _ _    -> nothingOrDefault
    KeyDom _           -> nothingOrDefault
    _ -> error "GenerationHelper.attrDefaultValues: unknown domain for attribute"
   where
     nothingOrDefault = if null
                          then constF (pre "Nothing")
                          else domainDefaultValue defaultctime domain

     -- add "Just" constructor if the attribute can be null-valued:
     addJust e = if null then applyF (pre "Just") [e] else e

--- Generates Curry expressions representing a default values
--- for a given domain.
--- The first argument contains an expression that is used for
--- ClockTime attributes (it is set to the current
--- time as a default value).
domainDefaultValue :: CExpr -> Domain -> CExpr
domainDefaultValue defaultctime domain = case domain of
    IntDom    _  -> CLit (CIntc 0)
    FloatDom  _  -> CLit (CFloatc 0)
    CharDom   _  -> CLit (CCharc ' ')
    StringDom _  -> string2ac []
    BoolDom   _  -> constF (pre "False")
    DateDom   _  -> defaultctime
    UserDefined _ _ -> list2ac [] -- no support of user-defined default values
    KeyDom _    -> CLit (CIntc 0)
    _ -> error "GenerationHelper.domainDefaultValue: unknown domain"

-- Is the attribute domain a string domain?
isStringDom :: Domain -> Bool
isStringDom dom = case dom of
                   StringDom _ -> True
                   _           -> False

hasDateAttribute :: [Attribute] -> Bool
hasDateAttribute = any isDate
 where
  isDate (Attribute _ domain _ _) = case domain of
    DateDom _   -> True
    _           -> False

combinator :: Int -> QName
combinator n
 | n==0 = error "GenerationHelper.combinator: empty attribute list"
 | n==1
 = error "GenerationHelper.combinator: no combinator for list of length 1"
 | n>14      = error "GenerationHelper.combinator: attribute list too long"
 | n==2      = (wuiModule "wPair")
 | n==3      = (wuiModule "wTriple")
 | otherwise = (wuiModule $ "w" ++ show n ++ "Tuple")

-- Associate to each attribute of the argument list a WUI specification
-- as an abstract Curry program
attrWidgets :: [Attribute] -> [CExpr]
attrWidgets ((Attribute _ domain _ null):attrlist) =
  (widgetFor domain null) : (attrWidgets attrlist)
attrWidgets [] = []

widgetFor :: Domain -> Bool -> CExpr
widgetFor domain null =
  case domain of
    IntDom _    -> addMaybe (constF (wuiModule "wInt"))
    FloatDom _  -> addMaybe (constF (wuiModule "wFloat"))
    CharDom _   -> addMaybe (constF (wuiModule "wString"))
    StringDom _ -> if null then constF (spiceyModule,"wString")
                           else constF (wuiModule "wRequiredString")
         --constF (wuiModule (if null then "wString" else "wRequiredString"))
    BoolDom _   -> addMaybe (constF (wuiModule "wBoolean"))
    DateDom _   -> addMaybe (constF (spiceyModule, "wDateType"))
    UserDefined _ _ -> addMaybe (applyF (wuiModule "wCheckBool")
                                        [applyF (html "htxt") [string2ac ""]])
    KeyDom _    -> addMaybe (constF (wuiModule "wInt"))
    _ -> error "widgetFor: unknown domain for attribute"
 where
  -- adds a Maybe WUI if null values are allowed
  addMaybe e =
    if null
     then applyF (spiceyModule,"wUncheckMaybe")
            [domainDefaultValue
               (applyF (timeModule, "toClockTime")
                 [applyF (timeModule, "CalendarTime")
                         (map (CLit . CIntc) [2018,1,1,0,0,0,0])])
               domain, e]
     else e


showQName :: QName -> String
showQName (mn,fn) = mn ++ "." ++ fn