{-| This module defines how the derived Haskell data types are represented.
- It is useful for writing type conversion rules.
-}
module Elm.TyRep where

import           Data.List
import           Data.Proxy
import           Data.Typeable    (TyCon, TypeRep, Typeable, splitTyConApp,
                                   tyConName, typeRep, typeRepTyCon)

import           Data.Aeson.Types (SumEncoding (..))
import           Data.Maybe       (fromMaybe)
import           Data.Monoid      ((<>))

-- | Type definition, including constructors.
data ETypeDef
   = ETypeAlias EAlias
   | ETypePrimAlias EPrimAlias
   | ETypeSum ESum
     deriving (Show, Eq)

-- | Type construction : type variables, type constructors, tuples and type
-- application.
data EType
   = ETyVar ETVar
   | ETyCon ETCon
   | ETyApp EType EType
   | ETyTuple Int
   deriving (Show, Eq, Ord)

{-| Type constructor:

> ETCon "Int"
-}
newtype ETCon
   = ETCon
   { tc_name :: String
   } deriving (Show, Eq, Ord)

{-| Type variable:

> ETVar "a"
-}
newtype ETVar
   = ETVar
   { tv_name :: String
   } deriving (Show, Eq, Ord)


{-| Type name:

> ETypeName "Map" [ETVar "k", ETVar "v"]
-}
data ETypeName
   = ETypeName
   { et_name :: String
   , et_args :: [ETVar]
   } deriving (Show, Eq, Ord)

data EPrimAlias
   = EPrimAlias
   { epa_name :: ETypeName
   , epa_type :: EType
   } deriving (Show, Eq, Ord)

data EAlias
   = EAlias
   { ea_name         :: ETypeName
   , ea_fields       :: [(String, EType)]
   , ea_omit_null    :: Bool
   , ea_newtype      :: Bool
   , ea_unwrap_unary :: Bool
   } deriving (Show, Eq, Ord)

data SumTypeFields
    = Anonymous [EType]
    | Named [(String, EType)]
    deriving (Show, Eq, Ord)

isNamed :: SumTypeFields -> Bool
isNamed s =
    case s of
      Named _ -> True
      _       -> False

data SumTypeConstructor
    = STC
    { _stcName    :: String
    , _stcEncoded :: String
    , _stcFields  :: SumTypeFields
    } deriving (Show, Eq, Ord)

data ESum
    = ESum
    { es_name          :: ETypeName
    , es_constructors  :: [SumTypeConstructor]
    , es_type          :: SumEncoding'
    , es_omit_null     :: Bool
    , es_unary_strings :: Bool
    } deriving (Show, Eq, Ord)

-- | Transforms tuple types in a list of types. Otherwise returns
-- a singleton list with the original type.
unpackTupleType :: EType -> [EType]
unpackTupleType et = fromMaybe [et] (extract et)
    where
        extract :: EType -> Maybe [EType]
        extract ty = case ty of
                         ETyTuple 0 -> return []
                         ETyApp (ETyTuple _) t -> return [t]
                         ETyApp app@(ETyApp _ _) t -> fmap (++ [t]) (extract app)
                         _ -> Nothing

unpackToplevelConstr :: EType -> [EType]
unpackToplevelConstr t =
    reverse $
    flip unfoldr (Just t) $ \mT ->
        case mT of
          Nothing -> Nothing
          Just t' ->
              case t' of
                ETyApp l r ->
                    Just (r, Just l)
                _ ->
                    Just (t', Nothing)

class IsElmDefinition a where
    compileElmDef :: Proxy a -> ETypeDef

newtype SumEncoding' = SumEncoding' SumEncoding

instance Show SumEncoding' where
    show (SumEncoding' se) = case se of
                                 TaggedObject n f -> "TaggedObject " ++ show n ++ " " ++ show f
                                 ObjectWithSingleField -> "ObjectWithSingleField"
                                 TwoElemArray -> "TwoElemArray"
                                 UntaggedValue -> "UntaggedValue"

instance Eq SumEncoding' where
    SumEncoding' a == SumEncoding' b = case (a,b) of
                                           (TaggedObject a1 b1, TaggedObject a2 b2) -> a1 == a2 && b1 == b2
                                           (ObjectWithSingleField, ObjectWithSingleField) -> True
                                           (TwoElemArray, TwoElemArray) -> True
                                           (UntaggedValue, UntaggedValue) -> True
                                           _ -> False

instance Ord SumEncoding' where
    compare (SumEncoding' a) (SumEncoding' b) =
       case (a,b) of
          (TaggedObject a1 b1, TaggedObject a2 b2) -> compare a1 a2 <> compare b1 b2
          (ObjectWithSingleField, ObjectWithSingleField) -> EQ
          (TwoElemArray, TwoElemArray) -> EQ
          (UntaggedValue, UntaggedValue) -> EQ
          (TaggedObject _ _, _) -> LT
          (_, TaggedObject _ _) -> GT
          (ObjectWithSingleField, _) -> LT
          (_, ObjectWithSingleField) -> GT
          (UntaggedValue, _) -> LT
          (_, UntaggedValue) -> GT

defSumEncoding :: SumEncoding'
defSumEncoding = SumEncoding' ObjectWithSingleField

-- | Get an @elm-bridge@ type representation for a Haskell type.
-- This can be used to render the type declaration via
-- 'Elm.TyRender.ElmRenderable' or the the JSON serializer/parser names via
-- 'Elm.Json.jsonSerForType' and 'Elm.Json.jsonParserForType'.
toElmType :: (Typeable a) => Proxy a -> EType
toElmType ty = toElmType' $ typeRep ty
    where
        toElmType' :: TypeRep -> EType
        toElmType' rep
            -- String (A list of Char)
          | con == typeRepTyCon (typeRep (Proxy :: Proxy [])) &&
            args == [typeRep (Proxy :: Proxy Char)]  = ETyCon (ETCon "String")
            -- List is special because the constructor name is [] in Haskell and List in elm
          | con == typeRepTyCon (typeRep (Proxy :: Proxy [])) = ETyApp (ETyCon $ ETCon "List") (toElmType' (head args))
            -- The unit type '()' is a 0-ary tuple.
          | isTuple $ tyConName con = foldl ETyApp (ETyTuple $ length args) $ map toElmType' args
          | otherwise = typeApplication con args
            where
                (con, args) = splitTyConApp rep

        isTuple :: String -> Bool
        isTuple ('(':xs) = isTuple' $ reverse xs
          where
            isTuple' :: String -> Bool
            isTuple' (')':xs') = all (== ',') xs'
            isTuple' _         = False
        isTuple _ = False

        typeApplication :: TyCon -> [TypeRep] -> EType
        typeApplication con args = typeApplication' (reverse args)
          where
            typeApplication' [] = ETyCon (ETCon $ tyConName con)
            typeApplication' [x] =
              ETyApp
                (ETyCon $ ETCon $ tyConName con)
                (toElmType' x)
            typeApplication' (x:xs) =
              ETyApp (typeApplication' xs) (toElmType' x)