{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

module Elm
    ( ToElm (..)
    , Options (..)
    , Expr (..)
    , Primitive (..)
    , Generator (..)
    , defaultOptions
    , genericToElm
    , generateElm
    ) where

import           Data.Char
import           Data.List        hiding (unlines)
import           Data.List.Split
import           Data.Text        (Text)
import           Data.Time
import           GHC.Generics
import           Prelude          hiding (unlines)
import           System.Directory
import           System.FilePath

data Options = Options
    { recordSelectorModifier :: String -> String
    , jsonSelectorModifier   :: String -> String
    }

defaultOptions :: Options
defaultOptions = Options
    { recordSelectorModifier = id
    , jsonSelectorModifier   = id
    }

data Generator = Type | Decoder | Encoder
    deriving (Show, Eq, Ord)

data Primitive = Bool | Char | String | Float | Date | Int | Maybe | List
    deriving (Show, Eq)

data Expr = DataType String Expr
          | Record String Expr
          | Constructor String Expr
          | Selector String String Expr
          | Field Expr
          | Unit
          | Sum Expr Expr
          | Product Expr Expr
          | Primitive Primitive
    deriving (Show)

tab :: Int -> String -> String
tab times = (++) (take times $ repeat ' ')

surround :: String -> String -> String -> [String] -> [String]
surround a b c (d:ds) = (a ++ d) : (map ((++) b) ds) ++ [c]
surround a b c _ = a : c : []

unlines :: [String] -> String
unlines = concat . intersperse "\n"

isProduct :: Expr -> Bool
isProduct (Product (Primitive List) (Primitive Char)) = False
isProduct (Product _ _) = True
isProduct _ = False

elmType :: Expr -> String
elmType (Primitive t) = show t
elmType (DataType name _) = name
elmType (Product (Primitive List) (Primitive Char)) = elmType $ Primitive String
elmType (Product (Primitive List) t) =
    "List " ++ if isProduct t
               then "(" ++ elmType t ++ ")"
               else elmType t
elmType (Product (Primitive Maybe) t) =
    "Maybe " ++ if isProduct t
               then "(" ++ elmType t ++ ")"
               else elmType t
elmType (Field f) = elmType f
elmType d = error $ "Unsupported Type: " ++ show d

typeDefinition :: Expr -> String
typeDefinition (DataType name (Record _ expr)) = unlines
    [ "type alias " ++ name ++ " ="
    , unlines $ map (tab 4) $ surround "{ " ", " "}" $ build expr
    ]
    where build (Product s1 s2) = build s1 ++ build s2
          build (Selector selector _ t) = [selector ++ " : " ++ elmType t]
          build d = error $ "Unsupported Record type Selector definition: " ++ show d
typeDefinition d = error $ "Unsupported type definition: " ++ show d

elmEncoder :: Expr -> String
elmEncoder (Primitive t) = case t of
    Bool ->
        "Json.Encode.bool"
    String ->
        "Json.Encode.string"
    Float ->
        "Json.Encode.float"
    Int ->
        "Json.Encode.int"
    p -> error $ "No encoder for Primitive known: " ++ show p
elmEncoder (Field f) = elmEncoder f
elmEncoder (DataType name _) = "encode" ++ name
elmEncoder (Product (Primitive List) (Primitive Char)) = elmEncoder $ Primitive String
elmEncoder (Product (Primitive List) t) =
    concat $ surround "(" " << " ")"
        [ "Json.Encode.list"
        , "List.map " ++ elmEncoder t
        ]
elmEncoder (Product (Primitive Maybe) t) =
    concat $ surround "(" " << " ")"
        [ "Maybe.withDefault Json.Encode.null"
        , "Maybe.map " ++ elmEncoder t
        ]
elmEncoder d = error $ "No encoder for definition known: " ++ show d

encoder :: Expr -> String
encoder (DataType name (Record _ expr)) = unlines
    [ func ++ " : " ++ name ++ " -> Json.Encode.Value"
    , func ++ " o ="
    , tab 4 "Json.Encode.object"
    , unlines $ map (tab 8) $ surround "[ " ", " "]" $ build expr
    ]
    where func = "encode" ++ name
          build (Product s1 s2) = build s1 ++ build s2
          build (Selector recordSel jsonSel t) =
              [ concat $ surround "(" ", " ")"
                  [ show jsonSel
                  , (elmEncoder t) ++ " o." ++ recordSel
                  ]
              ]
          build d = error $ "Unsupported Record encoder Selector definition: " ++ show d
encoder d = error $ "Unsupported encoder definition: " ++ show d

elmDecoder :: Expr -> String
elmDecoder (Primitive t) = case t of
    String ->
        "Json.Decode.string"
    Int ->
        "Json.Decode.int"
    Float ->
        "Json.Decode.float"
    Date ->
        "Json.Decode.Extra.date"
    Bool ->
        "Json.Decode.bool"
    p -> error $ "No decoder for Primitive known: " ++ show p
elmDecoder (Field f) = elmDecoder f
elmDecoder (DataType name _) = "decode" ++ name
elmDecoder (Product (Primitive List) (Primitive Char)) = elmDecoder $ Primitive String
elmDecoder (Product (Primitive List) t) =
    "Json.Decode.list " ++ if isProduct t
                           then "(" ++ elmDecoder t ++ ")"
                           else elmDecoder t
elmDecoder (Product (Primitive Maybe) t) =
    "Json.Decode.maybe " ++ if isProduct t
                            then "(" ++ elmDecoder t ++ ")"
                            else elmDecoder t
elmDecoder d = error $ "No decoder for definition known: " ++ show d

decoder :: Expr -> String
decoder (DataType name (Record _ expr)) = unlines
    [ func ++ " : Json.Decode.Decoder " ++ name
    , func ++ " ="
    , tab 4 "Json.Decode.succeed " ++ name
    , unlines $ map (tab 8) $ build expr
    ]
    where func = "decode" ++ name
          build (Product s1 s2) = build s1 ++ build s2
          build (Selector _ selector t) =
              [ concat $ surround "|: (" " := " ")"
                  [ show selector
                  , elmDecoder t
                  ]
              ]
          build d = error $ "Unsupported Record decoder Selector definition: " ++ show d
decoder d = error $ "Unsupported decoder definition: " ++ show d

imports :: [(Expr, [Generator])] -> [String]
imports inclusions = map format $ ti ++ di ++ ei
    where generators = concat $ map snd inclusions
          ti = if Type `elem` generators
               then [ ("Date", Just "Date")
                    ]
               else []
          di = if Decoder `elem` generators
               then [ ("Json.Decode", Just "(:=)")
                    , ("Json.Decode.Extra", Just "(|:)")
                    ]
               else []
          ei = if Encoder `elem` generators
               then [ ("Json.Encode", Nothing)
                    ]
               else []
          format (moduleName, Nothing) = "import " ++ moduleName
          format (moduleName, Just exp) = "import " ++ moduleName ++ " exposing (" ++ exp ++ ")"

generate :: Generator -> Expr -> String
generate Type = typeDefinition
generate Decoder = decoder
generate Encoder = encoder

generateElm :: FilePath -> String -> [String] -> [(Expr, [Generator])] -> IO ()
generateElm destination moduleName customImports inclusions = do
    createDirectoryIfMissing True directory
    writeFile filePath fileBody
    putStrLn $ "Generated: " ++ filePath
    where namespace = "module " ++ moduleName ++ " exposing (..)"
          extraImports = map (\i -> "import " ++ i ++ " exposing (..)") customImports
          allImports = unlines $ imports inclusions ++ extraImports
          definitions = map (\(e, gs) -> unlines $ pad $ map (flip generate e) gs) inclusions
          pad = intersperse "\n"
          fileBody = unlines $ pad $ filter (not . null) $
              namespace : allImports : definitions
          filePath = intercalate "/" (filter (not . null) $ destination : splitOn "." moduleName) ++ ".elm"
          directory = takeDirectory filePath

class ToElm a where
    toElm :: a -> Expr
    default toElm :: (Generic a, GToElm (Rep a)) => a -> Expr
    toElm = genericToElm defaultOptions

instance ToElm Bool where
    toElm _ = Primitive Bool

instance ToElm Char where
    toElm _ = Primitive Char

instance ToElm Text where
    toElm _ = Primitive String

instance ToElm Float where
    toElm _ = Primitive Float

instance ToElm Double where
    toElm _ = Primitive Float

instance ToElm UTCTime where
    toElm _ = Primitive Date

instance ToElm Int where
    toElm _ = Primitive Int

instance (ToElm a) => ToElm (Maybe a) where
    toElm _ = Product (Primitive Maybe) $ toElm (undefined :: a)

instance (ToElm a) => ToElm [a] where
    toElm _ = Product (Primitive List) $ toElm (undefined :: a)

class GToElm f where
    gToElm :: Options -> f a -> Expr

instance (GToElm f, Datatype d) => GToElm (D1 d f) where
    gToElm opts d@(M1 b) =
        DataType name expr
        where name = datatypeName d
              expr = gToElm opts b

instance (GToElm f, Constructor c) => GToElm (C1 c f) where
    gToElm opts c@(M1 s) =
        if conIsRecord c
            then Record name expr
            else Constructor name expr
        where name = conName c
              expr = gToElm opts s

instance (Selector c,GToElm f) => GToElm (S1 c f) where
    gToElm opts@(Options {..}) s@(M1 x) = Selector
        (dcFirst $ notEmpty "Record" $ recordSelectorModifier name)
        (notEmpty "Json" $ jsonSelectorModifier name) expr
        where name = selName s
              expr = gToElm opts x
              notEmpty ident as = if length as > 0
                  then as
                  else error $ ident ++ "selector modifier results in empty selector"
              dcFirst (a:as) = toLower a : as
              dcFirst _ = undefined

instance (ToElm c) => GToElm (K1 R c) where
    gToElm _ (K1 x) =
        Field $ toElm x

instance GToElm U1 where
    gToElm _ _ =
        Unit

instance (GToElm f, GToElm g) => GToElm (f :+: g) where
  gToElm opts _ =
      Sum (gToElm opts (undefined :: f p)) (gToElm opts (undefined :: g p))

instance (GToElm f, GToElm g) => GToElm (f :*: g) where
  gToElm opts _ =
      Product (gToElm opts (undefined :: f p)) (gToElm opts (undefined :: g p))

genericToElm :: (Generic a, GToElm (Rep a)) => Options -> a -> Expr
genericToElm opts = gToElm opts . from