{-# OPTIONS_GHC -fglasgow-exts #-}
{-# OPTIONS_GHC -fallow-overlapping-instances #-}
{-# OPTIONS_GHC -fallow-undecidable-instances #-}

module Tc2CHR where

import Debug.Trace
import Text.PrettyPrint.HughesPJ
import Data.Char(toUpper,toLower)
import Data.List(intersperse,intersect)

import Language.Haskell.Hsx

tc2chr file = do
  source <- readFile (file++".hs")
  writeFile (file++".chr") $ render $ translateModule $ parseModule source

translateModule (ParseOk (HsModule srcLoc (Module m) mes is decls)) = 
     text (":- module("++decap m++",["++getPredicates decls ""++"]).")
  $$ text ""
  $$ text ":- use_module(library(chr))."
  $$ text ""
  $$ translate [] decls
  where getPredicates (HsClassDecl _ _ n ns _ _:decls) ps = 
          getPredicates decls (down n++"/"++arity++comma ps)
          where arity = show (length ns)
        getPredicates (_:decls) ps = getPredicates decls ps
        getPredicates [] ps = ps
        comma cs = if null cs then "" else ", "++cs


translate env (c@(HsClassDecl _ ctxt n ns fds ds):decls) = 
     text ("/* "++prettyPrint c++"\n*/")
  $$ text ":- chr_constraint" <+> text constraints <> text "."
  $$ text ""
  $$ text "/* one constraint, two roles + superclasses */"
  $$ namePars <+> text "<=>" <+> inferPars <> comma <+> memoPars <> comma <+> context <> text "."
  $$ text ""
  $$ text "/* functional dependencies */"
  $$ vcat (map fd2chr fds)
  $$ text ""
  $$ text "/* remove duplicates */"
  $$ inferPars <+> text "\\" <+> inferPars <+> text "<=> true."
  $$ memoPars <+> text "\\" <+> memoPars <+> text "<=> true."
  $$ text ""
  $$ translate ((name,c):env) decls
  where
    name  = down n
    infer = "infer_"++name
    memo  = "memo_"++name
    pars  = map up ns
    arity = length ns
    namePars  = constraint name pars
    inferPars = constraint infer pars
    memoPars  = constraint memo pars
    context = text $ if null ctxt 
                     then "true" 
                     else concat $ intersperse ", " $ map ctxtConstraint ctxt
    ctxtConstraint (HsClassA hsQName ts) = 
      qNameBase hsQName++"("++(concat $ intersperse ", " $ map convertType ts)++")"
    constraints = name++"/"++show arity
                ++", "++infer++"/"++show arity
                ++", "++memo++"/"++show arity
    -- no guarantee that adding a number will give a free var..
    freeRange     range  n = map (\par->if par `elem` range then par++n else par) 
    freeNonDomain domain n = map (\par->if par `elem` domain then par else par++n) 
    rangeConstraint range  = text (up range++"1"++"="++up range++"2")
    fd2chr fd@(HsFunDep domain range@[_]) = 
      if length domain==arity-1 
      then text ("/* full FD: "++prettyPrint fd++" */") 
           $$ constraint memo (freeRange rangeNames "1" pars) <> comma 
              <+> constraint memo (freeRange rangeNames "2" pars) 
              <+> text "==>" <+> hcat (punctuate comma (map rangeConstraint range))
              <> text "."
           $$ text ""
      else text ("/* non-full FD: "++prettyPrint fd++" */")
           $$ constraint memo (freeNonDomain domainNames "1" pars) <> comma 
              <+> constraint memo (freeNonDomain domainNames "2" pars) 
              <+> text "==>" <+> hcat (punctuate comma (map rangeConstraint range))
              <> text "."
           $$ text ""
      where rangeNames  = map up range
            domainNames = map up domain
    fd2chr (HsFunDep _ _) = error "only single-range fds supported so far"
-- | HsInstDecl	 SrcLoc HsContext HsQName [HsType] [HsDecl]
translate env (i@(HsInstDecl _ ctxt qn ts' ds):decls) =
     text "/* instance inference: */"
  $$ text ("/* "++prettyPrint i++"\n*/")
  $$ constraint infer ts <+> text "<=>" <+> context <> text "."
  $$ text ""
  $$ text "/* instance improvements: */"
  $$ vcat (map fd2chr fds)
  $$ text ""
  $$ translate env decls
  where name    = qNameBase qn
        Just (HsClassDecl _ _ _ ns fds _) = lookup name env
        vars    = map up ns
        arity   = length ns
        infer   = "infer_"++name
        memo    = "memo_"++name
        ts      = map convertType ts'
        ctxtConstraint (HsClassA hsQName ts) = 
          qNameBase hsQName++"("++(concat $ intersperse ", " $ map convertType ts)++")"
        context = text $ if null ctxt 
                         then "true" 
                         else (concat $ intersperse ", " $ map ctxtConstraint ctxt)
        -- no guarantee that the class variables will be free in the instances..
        vars' = tryHarder vars
          where tryHarder vars | (not . null) (vars `intersect` fvTs ts') =
                  tryHarder (map (++"_") vars)
                tryHarder vars | otherwise = vars
        freeNonDomain domainNames ts = 
          zipWith (\t (v,v')->if v `elem` domainNames then t else v') ts (zip vars vars')
        -- TODO: need to handle repeated variables correctly, not replace them!
        fd2chr fd@(HsFunDep domain range@[_]) = 
             (if length domain==arity-1 
              then text ("/* full FD: "++prettyPrint fd++" */") 
              else text ("/* non-full FD: "++prettyPrint fd++" */"))
          $$ constraint memo (freeNonDomain domainNames ts) <+> text "==>" 
              <+> hcat (punctuate comma rangeConstraints) <> text "." 
          $$ text ""
          where domainNames = map up domain
                rangeNames  = map up range
                rangeConstraints = [text v' <> text "=" <> text t 
                                   |(t,(v,v')) <- zip ts (zip vars vars'), v `elem` rangeNames]
        fd2chr (HsFunDep _ _) = error "only single-range fds supported so far"
translate env (all:decls) =
     text ("/* "++prettyPrint all++"\n*/")
  $$ text ""
  $$ translate env decls
translate env [] = empty

constraint n ps = text (n++"(") <> hcat (punctuate comma (map text ps)) <> text ")"

convertTypes sep ts = concat $ intersperse sep $ map convertType ts

convertType (HsTyForall mbns ctxt t) = error "don't know how to convert forall"
convertType (HsTyFun f x)            = "to("++convertType f++", "++convertType x++")"
convertType t@(HsTyTuple boxed [])   = "nil" -- ignoring boxed
convertType t@(HsTyTuple boxed ts)   = "("++convertTypes ", " ts++")" -- ignoring boxed
convertType t@(HsTyApp _ _)          = collectApp t ""
convertType (HsTyVar n)              = up n
convertType (HsTyCon qn)             = qNameBase qn

collectApp (HsTyCon qn)          ts = qNameBase qn++"("++ts++")"
collectApp (HsTyApp t1 t2)       ts = collectApp t1 (convertType t2++comma ts)
  where comma cs = if null cs then "" else ", "++cs
collectApp x                     ts = error $ "collectApp: "++show x

fvTs = concatMap fvT
fvT (HsTyForall mbns ctxt t) = error "fvT don't know how to handle forall" --why maybe?
fvT (HsTyVar n) = [up n]
fvT (HsTyCon n) = []
fvT (HsTyTuple boxed ts) = fvTs ts -- ignoring boxed
fvT (HsTyFun f x) = fvT f++fvT x
fvT (HsTyApp m n) = fvT m++fvT n

cap (c:cs) = toUpper c:cs
decap (c:cs) = toLower c:cs

qNameBase (UnQual n)          = down n
qNameBase (Special HsListCon) = "list"
qNameBase (Special HsFunCon)  = "to"
qNameBase x                   = error $ "qNameBase: "++show x

nameBase (HsIdent n) = n
nameBase (HsSymbol n) = error $ "nameBase: HsSymbol "++n++" not supported"

up = cap . nameBase
down = decap . nameBase