{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-|
Functions in this module are used to generate Elm modules. Note that the generated modules depend on the @bartavelle/json-helpers@ package.

-}
module Elm.Module where

import           Control.Arrow (second)
import           Data.List
import           Data.Proxy

import           Elm.Json
import           Elm.TyRender
import           Elm.TyRep
import           Elm.Versions

-- | Existential quantification wrapper for lists of type definitions
data DefineElm
   = forall a. IsElmDefinition a => DefineElm (Proxy a)

-- | The module header line for this version of Elm
moduleHeader :: ElmVersion
             -> String
             -> String
moduleHeader _ moduleName = "module " ++ moduleName ++ " exposing(..)"

-- | Creates an Elm module for the given version. This will use the default
-- type conversion rules (to -- convert @Vector@ to @List@, @HashMap a b@
-- to @List (a,b)@, etc.).
makeElmModuleWithVersion :: ElmVersion
                         -> String  -- ^ Module name
                         -> [DefineElm]  -- ^ List of definitions to be included in the module
                         -> String
makeElmModuleWithVersion elmVersion moduleName defs = unlines
    [ moduleHeader elmVersion moduleName
    , ""
    , "import Json.Decode"
    , "import Json.Encode exposing (Value)"
    , "-- The following module comes from bartavelle/json-helpers"
    , "import Json.Helpers exposing (..)"
    , "import Dict exposing (Dict)"
    , "import Set exposing (Set)"
    , ""
    , ""
    ] ++ makeModuleContent defs

-- | Creates an Elm module. This will use the default type conversion rules (to
-- convert @Vector@ to @List@, @HashMap a b@ to @List (a,b)@, etc.).
--
-- default to 0.19
makeElmModule :: String -- ^ Module name
              -> [DefineElm] -- ^ List of definitions to be included in the module
              -> String
makeElmModule = makeElmModuleWithVersion Elm0p19

-- | Generates the content of a module. You will be responsible for
-- including the required Elm headers. This uses the default type
-- conversion rules.
makeModuleContent :: [DefineElm] -> String
makeModuleContent = makeModuleContentWithAlterations defaultAlterations

-- | Generates the content of a module, using custom type conversion rules.
makeModuleContentWithAlterations :: (ETypeDef -> ETypeDef) -> [DefineElm] -> String
makeModuleContentWithAlterations alt = intercalate "\n\n" . map mkDef
    where
      mkDef (DefineElm proxy) =
          let def = alt (compileElmDef proxy)
          in renderElm def ++ "\n" ++ jsonParserForDef def ++ "\n" ++ jsonSerForDef def ++ "\n"

{-| A helper function that will recursively traverse type definitions and let you convert types.

> myAlteration : ETypeDef -> ETypeDef
> myAlteration = recAlterType $ \t -> case t of
>                   ETyCon (ETCon "Integer") -> ETyCon (ETCon "Int")
>                   ETyCon (ETCon "Text")    -> ETyCon (ETCon "String")
>                   _                        -> t

-}
recAlterType :: (EType -> EType) -> ETypeDef -> ETypeDef
recAlterType f td = case td of
                     ETypeAlias a -> ETypeAlias (a { ea_fields = map (second f') (ea_fields a) })
                     ETypePrimAlias (EPrimAlias n t) -> ETypePrimAlias (EPrimAlias n (f' t))
                     ETypeSum s -> ETypeSum (s { es_constructors = map alterTypes (es_constructors s) })
    where
      alterTypes :: SumTypeConstructor -> SumTypeConstructor
      alterTypes (STC cn dn s) = STC cn dn $ case s of
                      Anonymous flds -> Anonymous (map f' flds)
                      Named flds     -> Named (map (second f') flds)
      f' (ETyApp a b) = f (ETyApp (f' a) (f' b))
      f' x            = f x

-- | Given a list of type names, will @newtype@ all the matching type
-- definitions.
newtypeAliases :: [String] -> ETypeDef -> ETypeDef
newtypeAliases nts (ETypeAlias e) = ETypeAlias $ if et_name (ea_name e) `elem` nts
                                                     then e { ea_newtype = True }
                                                     else e
newtypeAliases _ x = x

{-| A default set of type conversion rules:

 * @HashSet a@, @Set a@ -> if @a@ is comparable, then @Set a@, else @List a@
 * @HashMap String v@, @Map String v@ -> @Dict String v@
 * @HashMap k v@, @Map k v@ -> @List (k, v)@
 * @Integer@ -> @Int@
 * @Text@ -> @String@
 * @Vector@ -> @List@
 * @Double@ -> @Float@
 * @Tagged t v@ -> @v@
-}
defaultAlterations :: ETypeDef -> ETypeDef
defaultAlterations = recAlterType defaultTypeAlterations

defaultTypeAlterations :: EType -> EType
defaultTypeAlterations t = case t of
                            ETyApp (ETyCon (ETCon "HashSet")) s             -> checkSet $ defaultTypeAlterations s
                            ETyApp (ETyCon (ETCon "Set")) s                 -> checkSet $ defaultTypeAlterations s
                            ETyApp (ETyApp (ETyCon (ETCon "HashMap")) k) v  -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v)
                            ETyApp (ETyApp (ETyCon (ETCon "THashMap")) k) v -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v)
                            ETyApp (ETyCon (ETCon "IntMap")) v              -> checkMap int (defaultTypeAlterations v)
                            ETyApp (ETyApp (ETyCon (ETCon "Map")) k) v      -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v)
                            ETyApp (ETyApp (ETyCon (ETCon "Tagged")) _) v   -> defaultTypeAlterations v
                            ETyApp x y                                      -> ETyApp (defaultTypeAlterations x) (defaultTypeAlterations y)
                            ETyCon (ETCon "Integer")                        -> int
                            ETyCon (ETCon "Natural")                        -> int
                            ETyCon (ETCon "Int32")                          -> int
                            ETyCon (ETCon "Int64")                          -> int
                            ETyCon (ETCon "Text")                           -> tc "String"
                            ETyCon (ETCon "Vector")                         -> tc "List"
                            ETyCon (ETCon "Double")                         -> tc "Float"
                            ETyCon (ETCon "UTCTime")                        -> tc "Posix"
                            _                                               -> t
    where
        int = tc "Int"
        isComparable (ETyCon (ETCon n)) = n `elem` ["String", "Int", "Float", "Posix", "Char"]
        isComparable _                  = False -- TODO Lists and Tuples of comparable types
        tc = ETyCon . ETCon
        checkMap k v | isComparable k = ETyApp (ETyApp (tc "Dict") k) v
                     | otherwise  = ETyApp (tc "List") (ETyApp (ETyApp (ETyTuple 2) k) v)
        checkSet s | isComparable s = ETyApp (tc "Set") s
                   | otherwise = ETyApp (tc "List") s
