{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE TypeOperators     #-}

module Language.ATS.Generate
    ( exec
    , generateATS
    ) where

import           Cases                        (snakify)
import           Control.Lens                 (over, _head)
import           Data.Char                    (toUpper)
import           Data.Maybe                   (fromJust)
import qualified Data.Text                    as T
import           Language.ATS                 as ATS
import           Language.Haskell.Exts.Parser
import           Language.Haskell.Exts.Syntax as HS
import           Options.Generic

data Program = Program { src    :: FilePath <?> "Haskell source file"
                       , target :: FilePath <?> "ATS target"
                       } deriving (Generic, ParseRecord)

convertConventions :: String -> String
convertConventions = T.unpack . snakify . T.pack

pattern QNamed :: l -> l -> String -> QName l
pattern QNamed x y s = UnQual x (Ident y s)

pattern EmptyQualCon :: l -> ConDecl l -> QualConDecl l
pattern EmptyQualCon x cd = QualConDecl x Nothing Nothing cd

qnameToString :: QName a -> String
qnameToString (QNamed _ _ s) = convertConventions s
qnameToString _              = undefined

toStringATS' :: QName a -> ATS.Type
toStringATS' (QNamed _ _ "Int")     = ATS.Int
toStringATS' (QNamed _ _ "Float")   = ATS.Float
toStringATS' (QNamed _ _ "Integer") = Named (Unqualified "Intinf")
toStringATS' (QNamed _ _ "String")  = Named (Unqualified "Strptr1") -- TODO string?
toStringATS' (QNamed _ _ "Bool")    = ATS.Bool
toStringATS' (QNamed _ _ "Word")    = Named (Unqualified "uint")
toStringATS' (QNamed _ _ "Double")  = ATS.Double
toStringATS' _                      = undefined

-- TODO warn on un-banged types
-- TODO built-in constructors (particularly lists)
typeToType :: HS.Type a -> ATS.Type
typeToType (TyCon _ qn)                      = toStringATS' qn
typeToType (TyVar _ n)                       = Named $ Unqualified (toStringATS n)
typeToType (TyApp _ (TyCon _ qn) t'@TyCon{}) = Dependent (Unqualified $ qnameToString qn) [typeToType t']
typeToType (TyApp _ t@TyApp{} t'@TyCon{})    = over typeCallArgs (typeToType t':) $ typeToType t
typeToType (TyParen _ t)                     = typeToType t
typeToType (TyBang _ _ _ t)                  = typeToType t
typeToType (TyList _ t)                      = Dependent (Unqualified "List_vt") [typeToType t]
typeToType _                                 = undefined

-- TODO allow multiple
fieldDeclToType :: FieldDecl a -> (String, ATS.Type)
fieldDeclToType (FieldDecl _ [n] t) = (toStringATS n, typeToType t)
fieldDeclToType _                   = undefined

conDeclToType :: ConDecl a -> (String, Maybe ATS.Type)
conDeclToType (ConDecl _ n [])  = (toStringATS n, Nothing)
conDeclToType (ConDecl _ n [t]) = (toStringATS n, Just $ typeToType t)
conDeclToType (RecDecl _ n fs)  = (toStringATS n, Just $ AnonymousRecord undefined (fieldDeclToType <$> reverse fs))
conDeclToType _                 = undefined

toStringATS :: HS.Name a -> String
toStringATS (Ident _ s) = s
toStringATS _           = undefined

tyvarToArg :: TyVarBind a -> Arg
tyvarToArg (UnkindedVar _ n) = Arg (Both (toStringATS n) (Vt0p Plus))
tyvarToArg _                 = undefined

asATSName :: DeclHead a -> (String, [Arg])
asATSName (DHead _ n)    = (convertConventions $ toStringATS n, [])
asATSName (DHParen _ d)  = (fst $ asATSName d, [])
asATSName (DHApp _ d tb) = (fst $ asATSName d, tyvarToArg tb : snd (asATSName d))
asATSName _              = undefined

qualConDeclToType :: QualConDecl a -> ATS.Type
qualConDeclToType (EmptyQualCon _ cd) = fromJust $ snd $ conDeclToType cd
qualConDeclToType _                   = undefined

qualConDeclToLeaf :: QualConDecl a -> Leaf
qualConDeclToLeaf (EmptyQualCon _ cd) = Leaf [] (over _head toUpper $ convertConventions $ fst $ conDeclToType cd) [] (snd $ conDeclToType cd)
qualConDeclToLeaf _                   = undefined

asATSType :: Decl a -> Declaration
asATSType (DataDecl _ NewType{} _ dh [qcd] _)  = ViewTypeDef undefined (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToType qcd)
asATSType (DataDecl _ DataType{} _ dh [qcd] _) = ViewTypeDef undefined (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToType qcd)
asATSType (DataDecl _ DataType{} _ dh qcds _)  = SumViewType (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToLeaf <$> reverse qcds)
asATSType _                                    = undefined

-- TODO GDataDecl and DataFamDecl
isDataDecl :: Decl a -> Bool
isDataDecl DataDecl{} = True
isDataDecl _          = False

-- TODO imports
filterModule :: Module a -> [Decl a]
filterModule (Module _ _ _ _ ds) = filter isDataDecl ds
filterModule _                   = []

-- #include "contrib/atscntrb-hx-intinf/mylibies.hats"

modulePrint :: Module a -> String
modulePrint = printATS . ATS . reverse . fmap asATSType . filterModule

generateATS :: String -> String
generateATS hsSrc = modulePrint $ case parseModule hsSrc of
    ParseOk x           -> x
    ParseFailed loc msg -> error (show loc ++ "\n" ++ msg)

withFile :: FilePath -> FilePath -> IO ()
withFile p p' = do
    contents <- readFile p
    writeFile p' (generateATS contents)

exec :: IO ()
exec = do
    x <- getRecord "Generate ATS types for Haskell source code" :: IO Program
    withFile (unHelpful . src $ x) (unHelpful . target $ x)