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

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

import           Cases                        (snakify)
import           Control.Arrow
import           Control.Lens                 (over, _head)
import           Data.Char                    (toUpper)
import           Data.Either                  (lefts, rights)
import           Data.Maybe                   (fromJust)
import qualified Data.Text                    as T
import           Language.ATS                 as ATS
import           Language.ATS.Generate.Error
import           Language.Haskell.Exts
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 -> ErrM String
qnameToString (QNamed _ _ s) = Right $ convertConventions s
qnameToString _              = unsupported "qnameToString"

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

typeToType :: HS.Type a -> ErrM ATS.Type
typeToType (TyCon _ qn)                      = toStringATS' qn
typeToType (TyVar _ n)                       = Right $ Named $ Unqualified (toStringATS n)
typeToType (TyApp _ (TyCon _ qn) t'@TyCon{}) = Dependent <$> (Unqualified <$> qnameToString qn) <*> (pure <$> typeToType t')
typeToType (TyApp _ t@TyApp{} t'@TyCon{})    = over typeCallArgs <$> fmap (:) (typeToType t') <*> typeToType t
typeToType (TyParen _ t)                     = typeToType t
typeToType (TyBang _ _ _ t)                  = typeToType t
typeToType (TyList _ t)                      = Dependent (Unqualified "List_vt") <$> (pure <$> typeToType t)
typeToType _                                 = Left $ Unsupported "typeToType"

fieldDeclToType :: FieldDecl a -> ErrM (String, ATS.Type)
fieldDeclToType (FieldDecl _ [n] t) = (,) (toStringATS n) <$> typeToType t
fieldDeclToType _                   = Left $ Unsupported "fieldDeclToType"

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

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

tyvarToArg :: Bool -> TyVarBind a -> ErrM Arg
tyvarToArg False (UnkindedVar _ n) = Right $ Arg (Both (toStringATS n) (Vt0p None))
tyvarToArg True (UnkindedVar _ n)  = Right $ Arg (Both (toStringATS n) (Vt0p Plus))
tyvarToArg _ _                     = unsupported "tyvarToArg"

consM :: (Monad m) => m a -> m [a] -> m [a]
consM x xs = (:) <$> x <*> xs

asATSName :: DeclHead a -> ErrM (String, [Arg])
asATSName (DHead _ n)    = Right (convertConventions $ toStringATS n, [])
asATSName (DHParen _ d)  = (,) . fst <$> asATSName d <*> pure []
asATSName (DHApp _ d tb) = (,) . fst <$> asATSName d <*> consM (tyvarToArg False tb) (snd <$> asATSName d)
asATSName _              = unsupported "asATSName"

qualConDeclToType :: QualConDecl a -> ErrM ATS.Type
qualConDeclToType (EmptyQualCon _ cd) = fromJust . snd <$> conDeclToType cd
qualConDeclToType _                   = unsupported "qualConDeclToType"

qualConDeclToLeaf :: QualConDecl a -> ErrM Leaf
qualConDeclToLeaf (EmptyQualCon _ cd) = Leaf [] <$> (over _head toUpper . convertConventions . fst <$> conDeclToType cd) <*> pure [] <*> (snd <$> conDeclToType cd)
qualConDeclToLeaf _                   = unsupported "qualConDeclToLeaf"

addNils :: [Arg] -> [Arg]
addNils [] = [NoArgs]
addNils x  = x

-- TODO if it derives functor, use +
asATSType :: Decl a -> ErrM Declaration
asATSType (TypeDecl _ dh t) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> typeToType t
asATSType (DataDecl _ NewType{} _ dh [qcd] _)  = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> qualConDeclToType qcd
asATSType (DataDecl _ DataType{} _ dh [qcd] _) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> qualConDeclToType qcd
asATSType (DataDecl _ DataType{} _ dh qcds _)  = SumViewType <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> mapM qualConDeclToLeaf (reverse qcds)
asATSType _                                    = unsupported "asATSType"

-- TODO GDataDecl and DataFamDecl
isDataDecl :: Decl a -> Bool
isDataDecl TypeDecl{} = True
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"

-- TODO @rights@ for stuff.

modulePrint :: Module a -> (String, [GenerateError])
modulePrint = g . fmap asATSType . filterModule
    where g = (printATS . ATS . reverse . rights) &&& lefts

extends :: ParseMode
extends = defaultParseMode
    { extensions = [EnableExtension StandaloneDeriving] }

-- | Given a string containing Haskell, return a string containing ATS and
-- a list of warnings.
generateATS :: String -> ErrM (String, [GenerateError])
generateATS hsSrc = modulePrint <$> case parseModuleWithMode extends hsSrc of
    ParseOk x            -> Right x
    ParseFailed loc' msg -> syntaxError loc' msg

genATSTypes :: FilePath -> FilePath -> IO ()
genATSTypes p p' = do
    contents <- readFile p
    let warnDo (x, es) = mapM_ displayErr es >> writeFile p' x
    either displayErr warnDo (generateATS contents)

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