module Type.HS2PS where

import Language.Haskell.TH
import Control.Monad
import Control.Monad.Fail (MonadFail)
import Data.List
import Data.Traversable
import Data.Char
import Control.Arrow
import Data.Functor


writePSTypes :: FilePath -> [Name] -> IO ()
writePSTypes fp = writeFile fp . intercalate "\n" <=< runQ . traverse def2PS

def2PS :: Name -> Q String
def2PS = reify >=> decPS >=> tyConPS

type2PS :: Name -> ExpQ
type2PS = litE . stringL . typeMap

decPS :: Info -> DecQ
decPS = \case
  ClassI _ _ -> unacceptedConstructor "Info" "ClassI"
  ClassOpI _ _ _ -> unacceptedConstructor "Info" "ClassOpI"
  FamilyI _ _ -> unacceptedConstructor "Info" "FamilyI"
  PrimTyConI _ _ _ -> unacceptedConstructor "Info" "PrimTyConI"
  DataConI _ _ _ -> unacceptedConstructor "Info" "DataConI"
  PatSynI _ _ -> unacceptedConstructor "Info" "PatSynI"
  VarI _ _ _ -> unacceptedConstructor "Info" "VarI"
  TyVarI _ _ -> unacceptedConstructor "Info" "TyVarI"
  TyConI tyConIDec -> pure tyConIDec

tyConPS :: Dec -> Q String
tyConPS = \case
    FunD _ _ -> unacceptedConstructor "TyConI" "FunD"
    ValD _ _ _ -> unacceptedConstructor "TyConI" "ValD"
    TySynD _ _ _ -> unacceptedConstructor "TyConI" "TySynD"
    ClassD _ _ _ _ _ -> unacceptedConstructor "TyConI" "ClassD"
    InstanceD _ _ _ _ -> unacceptedConstructor "TyConI" "InstanceD"
    SigD _ _ -> unacceptedConstructor "TyConI" "SigD"
    ForeignD _ -> unacceptedConstructor "TyConI" "ForeignD"
    InfixD _ _ -> unacceptedConstructor "TyConI" "InfixD"
    PragmaD _ -> unacceptedConstructor "TyConI" "PragmaD"
    DataFamilyD _ _ _ -> unacceptedConstructor "TyConI" "DataFamilyD"
    DataInstD _ _ _ _ _ _ -> unacceptedConstructor "TyConI" "DataInstD"
    NewtypeInstD _ _ _ _ _ _ -> unacceptedConstructor "TyConI" "NewtypeInstD"
    TySynInstD _ _ -> unacceptedConstructor "TyConI" "TySynInstD"
    OpenTypeFamilyD _ -> unacceptedConstructor "TyConI" "OpenTypeFamilyD"
    ClosedTypeFamilyD _ _ -> unacceptedConstructor "TyConI" "ClosedTypeFamilyD"
    RoleAnnotD _ _ -> unacceptedConstructor "TyConI" "RoleAnnotD"
    StandaloneDerivD _ _ _ -> unacceptedConstructor "TyConI" "StandaloneDerivD"
    DefaultSigD _ _ -> unacceptedConstructor "TyConI" "DefaultSigD"
    PatSynD _ _ _ _ -> unacceptedConstructor "TyConI" "PatSynD"
    PatSynSigD _ _ -> unacceptedConstructor "TyConI" "PatSynSigD"
    NewtypeD [] typeName typeVars Nothing constructor _ ->
      renderNewtype typeName typeVars constructor
    DataD [] typeName typeVars Nothing [constructor] _ ->
      renderNewtype typeName typeVars constructor
    DataD [] typeName typeVars Nothing constructors _ -> do
      cs <- intercalate " | " <$> traverse renderConstructor constructors
      rTVars <- traverse renderTypeVariables typeVars <&> \vs ->
        if null vs then "" else ' ' : intercalate " " vs
      pure $ "data " <> nameBase typeName <> rTVars <> " = " <> cs
    x -> fail $ "tyConPS does not support: " <> show x

unacceptedConstructor :: MonadFail m => String -> String -> m a
unacceptedConstructor typeName constructorName = fail $
  "mkDef2PS does not accept " <> typeName <> " constructor: " <> constructorName

renderNewtype :: Name -> [TyVarBndr] -> Con -> Q String
renderNewtype typeName typeVars constructor = do
  rCon <- renderConstructor constructor
  rTVars <- traverse renderTypeVariables typeVars <&> \vs ->
    if null vs then "" else ' ' : intercalate " " vs
  pure $ "newtype " <> nameBase typeName <> rTVars <> " = " <> rCon

renderConstructor :: Con -> Q String
renderConstructor = \case
  NormalC conName types -> do
    renderedTypes <- for types \(_,t) -> opParen <$> renderType t
    pure $ nameBase conName <> (if null renderedTypes then "" else " ") <> intercalate " " renderedTypes
  RecC conName types -> do
    renderedTypes <- for types \(accessorName,_,conType) ->
      (\rt -> nameBase accessorName <> " :: " <> opParen rt) <$> renderType conType
    pure $ nameBase conName <> " {" <> intercalate ", " renderedTypes <> "}"
  x -> fail $ "renderConstructor is does not support: " <> show x

renderTypeVariables :: TyVarBndr -> Q String
renderTypeVariables = \case
  PlainTV n -> pure $ nameBase n
  KindedTV n StarT -> pure $ nameBase n
  KindedTV n kind -> fail $ "renderTypeVariables does not accept: KindedTV " <> nameBase n <> " " <> show kind

renderType :: Type -> Q String
renderType = \case
  ConT n -> pure $ typeMap n
  AppT x y -> do
    x' <- renderType x
    y' <- renderType y
    pure $ x' <> " " <> opParen y'
  TupleT 2 -> pure "Tuple"
  VarT n -> pure $ nameBase n
  x -> fail $ ("renderType: " <>) $ show x

typeMap :: Name -> String
typeMap = nameBase >>> \case
  "Word" -> "Int"
  "Double" -> "Number"
  "()" -> "Unit"
  "Text" -> "String"
  "ByteString" -> "String"
  x -> x

opParen :: String -> String
opParen xs | any isSpace xs = "(" <> xs <> ")"
           | otherwise = xs