GenHaskell.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  UI.GenHaskell
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Multifocal:
-- Bidirectional Two-level Transformation of XML Schemas
-- 
-- Generation of Haskell code for the source and input schemas and the corresponding lens transformation.
--
-----------------------------------------------------------------------------

module UI.GenHaskell (generateHaskell,generateHaskell') where
    
import Data.Equal
import Data.Transform.TwoLevel hiding (showType)
import Transform.Rules.Lenses
import Transform.Rewriting

import Data.Type as T hiding (Var)
import Data.Pf
import Data.Spine hiding (Con)
import Generics.Pointless.Functors hiding (rep)
import Generics.Pointless.Combinators

import Data.Map as Map hiding (map)
import Control.Monad.State as ST
import Language.Haskell.Exts.Syntax as Ext hiding (Rule)
import Language.Haskell.Exts.Pretty
import Data.List
import Data.Char

generateHaskell :: FilePath -> FilePath -> [FilePath] -> FilePath -> T.Type a -> RuleT -> IO ()
generateHaskell srcSchema tgtSchema sources output a r = case transform a r of
	Just (v,news) -> generateHaskell' srcSchema tgtSchema sources output a v news optimise_all_lns
	otherwise     -> putStrLn "Failed to apply transformation, no output generated."

generateHaskell' :: FilePath -> FilePath -> [FilePath] -> FilePath -> T.Type a -> View a -> Map String DynFctr -> Rule -> IO ()
generateHaskell' srcSchema tgtSchema sources output a (View lns b) news pfrule = do
	let newnames = (collectNewNames a ++ collectNewNames b)
	    newdatas = Map.toList $ Map.filterWithKey (\k a -> k `elem` newnames) news
	lns' <- reduceIO pfrule (Lns a b) lns
	let ast = topModule srcSchema tgtSchema sources newdatas a (View lns' b)
	writeFile output (prettyPrint ast)

-- | standard location of the code
loc :: SrcLoc
loc = SrcLoc "" 0 0

topModule :: FilePath -> FilePath -> [FilePath] -> [(String,DynFctr)] -> T.Type a -> View a -> Module
topModule srcSchema tgtSchema sources newdatas a (View lns b) = Module loc filename pragmas Nothing Nothing imports code
    where news = map fst newdatas
          pragmas :: [ModulePragma]
          pragmas = [LanguagePragma loc [Ident "TypeOperators",Ident "TypeFamilies"]]
          imports :: [ImportDecl]
          imports = [ importMAs "Ori" "Generics.Pointless.Lenses", importMAs "Ori" "Generics.Pointless.Lenses.RecursionPatterns"
                    , importMAs "Ori" "Generics.Pointless.Functors", importMAs "Ori" "Generics.Pointless.RecursionPatterns"
                    , importMAs "Ori" "Generics.Pointless.Combinators", importMAs "Ori" "Generics.Pointless.Lenses.Combinators"
                    , importMAs "Ori" "Generics.Pointless.Lenses.Examples.Examples", importMAs "Ori" "Data.Type", importMAs "Ori" "Prelude"
                    , importMAs "Ori" "UI.LensMenu"]
                    ++ map (importMAs "Ori") sources
          code = decls ++ instances ++ typeables ++ mus ++ sig ++ exp
              ++ [typeSignature news "srcType" a,typeExpression news "srcType"]
              ++ [typeSignature news "tgtType" b,typeExpression news "tgtType"]
              ++ [schemaExpression "srcSchema" srcSchema,schemaExpression "tgtSchema" tgtSchema]
              ++ [mainExpression]
          decls, instances, typeables, mus, sig :: [Decl]
          decls = map (\(s,DynF f) -> typeDecl news s f) newdatas
          instances = map (\(s,DynF f) -> typeInstance news s f) newdatas
          typeables = map (\(s,DynF f) -> typeTypeable news s) newdatas
          mus = map (\(s,DynF f) -> typeMu news s f) newdatas
          sig = [signature news "transformation" a b]
          exp = [expression news "transformation" (Pf $ Lns a b) lns]

filename :: ModuleName
filename = (ModuleName "Main")
        
importM :: String -> ImportDecl
importM name = ImportDecl { importLoc = loc, importModule = ModuleName name, importQualified = False
        , importSrc = False , importPkg = Nothing, importAs = Nothing, importSpecs = Nothing }
        
importMAs :: String -> String -> ImportDecl
importMAs ref name = (importM name) { importQualified = False, importAs = Just $ ModuleName ref }


typeConstructors :: [String] -> String -> Fctr f -> State Int [QualConDecl]
typeConstructors news name (f :+!: g) = do
    x <- typeConstructors news name f
    y <- typeConstructors news name g
    return (x ++ y)
typeConstructors news name f = do
    i <- ST.get
    ST.put (succ i)
    return [typeConstructor news name i f]

typeConstructor :: [String ] -> String -> Int -> Fctr f -> QualConDecl
typeConstructor news name i fctr = QualConDecl loc [] [] (ConDecl (Ident $ hsname name ++ "C" ++ show i) (typeConstructorProd news name fctr))
typeConstructorProd :: [String] -> String -> Fctr f -> [BangType]
typeConstructorProd news name (f :*!: g) = typeConstructorProd news name f ++ typeConstructorProd news name g
typeConstructorProd news name f = [UnBangedTy $ typeConstructor' news name (rep f (NewData name I))]
typeConstructor' :: [String] -> String -> T.Type a -> Ext.Type
typeConstructor' news name (T.List a) = TyList $ typeConstructor' news name a
typeConstructor' news name (Prod a b) = TyTuple Boxed [typeConstructor' news name a,typeConstructor' news name b]
typeConstructor' news name (Either a b) = TyApp (TyApp (TyCon (UnQual (Ident "Either"))) (typeConstructor' news name a)) (typeConstructor' news name b)
typeConstructor' news name a = showType news a

typeDecl :: [String] -> String -> Fctr f -> Decl
typeDecl news name fctr = DataDecl
    loc DataType [] (Ident $ hsname name) [] (evalState (typeConstructors news name fctr) 1) [(UnQual (Ident "Show"),[])]

typeInstance :: [String] -> String -> Fctr f -> Decl
typeInstance news name fctr = TypeInsDecl loc (TyApp (TyCon (UnQual (Ident "PF"))) (showType news (NewData name I))) (typeInstance' news fctr)
typeInstance' :: [String] -> Fctr f -> Ext.Type
typeInstance' news I = (TyCon (UnQual (Ident "Id")))
typeInstance' news L = (TyCon (Special ListCon))
typeInstance' news (K c) = TyApp (TyCon (UnQual (Ident "Const"))) $ showType news c
typeInstance' news (f :*!: g) = TyParen $ TyInfix (typeInstance' news f) (UnQual (Symbol ":*:")) (typeInstance' news g)
typeInstance' news (f :+!: g) = TyParen $ TyInfix (typeInstance' news f) (UnQual (Symbol ":+:")) (typeInstance' news g)
typeInstance' news (f :@!: g) = TyParen $ TyInfix (typeInstance' news f) (UnQual (Symbol ":@:")) (typeInstance' news g)

typeTypeable :: [String] -> String -> Decl
typeTypeable news name = InstDecl loc [] (UnQual (Ident "Typeable")) [showType news (NewData name I)] [InsDecl (PatBind loc (PVar (Ident "typeof")) Nothing (UnGuardedRhs (App (App (Con (UnQual (Ident "Data"))) (Lit (String name))) (Var (UnQual (Ident "fctrof"))))) (BDecls []))]

typeMu :: [String] -> String -> Fctr f -> Decl
typeMu news name fctr = InstDecl loc [] (UnQual (Ident "Mu")) [showType news (NewData name I)] (evalState (outMu name fctr) 1 ++ evalState (innMu name fctr) 1)

outMu :: String -> Fctr f -> State Int [InstDecl]
outMu name (f :+!: g) = do
    x <- outMu name f
    y <- outMu name g
    return (x ++ y)
outMu name f = do
    i <- ST.get
    ST.put (succ i)
    return [outMu' name i f]
outMu' :: String -> Int -> Fctr f -> InstDecl
outMu' name i fctr = InsDecl $ FunBind [Match loc (Ident "out")
    [PParen (PApp (UnQual (Ident $ hsname name ++ "C" ++ show i)) (evalState (outPat fctr) 'a'))]
    Nothing (UnGuardedRhs $ evalState (outRhs (rep fctr T.Int)) 'a') (BDecls [])]

innMu :: String -> Fctr f -> State Int [InstDecl]
innMu name (f :+!: g) = do
    x <- innMu name f
    y <- innMu name g
    return (x ++ y)
innMu name f = do
    i <- ST.get
    ST.put (succ i)
    return [innMu' name i f]
innMu' :: String -> Int -> Fctr f -> InstDecl
innMu' name i fctr = InsDecl $ FunBind [Match loc (Ident "inn") [evalState (innPat (rep fctr T.Int)) 'a']
               Nothing (UnGuardedRhs $ evalState (innRhs (name ++ "C" ++ show i) fctr) 'a')  (BDecls [])]

innRhs :: String -> Fctr f -> State Char Exp
innRhs cname f = do
	exps <- innRhs' f
	return $ foldl App (Con (UnQual (Ident $ hsname cname))) exps	

innRhs' :: Fctr f -> State Char [Exp]
innRhs' (f :*!: g) = do
	x <- innRhs' f
	y <- innRhs' g
	return (x ++ y)
innRhs' f = do
	c <- ST.get
	ST.put (succ c)
	return [Var (UnQual (Ident [c]))]

innPat :: T.Type a -> State Char Pat
innPat (Prod a b) = do
    x <- innPat a
    y <- innPat b
    return $ PTuple [x,y]
innPat a = do
    c <- ST.get
    ST.put (succ c)
    return $ PVar $ Ident [c]

outPat :: Fctr f -> State Char [Pat]
outPat (f :*!: g) = do
    x <- outPat f
    y <- outPat g
    return (x ++ y)
outPat f = do
    c <- ST.get
    ST.put (succ c)
    return $ [PVar $ Ident [c]]

outRhs :: T.Type a -> State Char Exp
outRhs (Prod a b) = do
    x <- outRhs a
    y <- outRhs b
    return $ Tuple [x,y]
outRhs a = do
    c <- ST.get
    ST.put (succ c)
    return $ Var (UnQual (Ident [c]))

-- ** XML types

typeSignature :: [String] -> String -> T.Type a -> Decl
typeSignature news name t = TypeSig loc [Ident name] (TyApp typ (showType news t))
	where typ = TyCon $ Qual (ModuleName "Ori") $ Ident "Type"
typeExpression :: [String] -> String -> Decl
typeExpression news name = PatBind loc (PVar $ Ident name) Nothing (UnGuardedRhs $ Var (UnQual (Ident "typeof"))) (BDecls [])

schemaExpression :: String -> FilePath -> Decl
schemaExpression name s = PatBind loc (PVar $ Ident name) Nothing (UnGuardedRhs $ Lit $ String s) (BDecls [])

mainExpression :: Decl
mainExpression = PatBind loc (PVar $ Ident "main") Nothing (UnGuardedRhs rhs) (BDecls [])
	where rhs = App (App (App (App (App lensmenu srcSchema) tgtSchema) srcType) tgtType) transformation
	      lensmenu = Var (UnQual (Ident "lensmenu"))
	      srcSchema = Var (UnQual (Ident "srcSchema"))
	      tgtSchema = Var (UnQual (Ident "tgtSchema"))
	      srcType = Var (UnQual (Ident "srcType"))
	      tgtType = Var (UnQual (Ident "tgtType"))
	      transformation = Var (UnQual (Ident "transformation"))

-- ** point-free expressions

signature :: [String] -> String -> T.Type a -> T.Type b -> Decl
signature news name a b = TypeSig loc [Ident name] (TyApp (TyApp lens src) tgt)
    where lens = TyCon $ UnQual $ Ident "Lens"
          src = showType news a
          tgt = showType news b

expression :: [String] -> String -> T.Type a -> a -> Decl
expression news n t v = PatBind loc name Nothing (UnGuardedRhs $ showExp news t v) (BDecls [])
    where name = PVar $ Ident n

showType :: [String] -> T.Type a -> Ext.Type
showType news (NewData n f)
    | n `elem` news = TyCon $ Qual filename $ Ident $ hsname n
    | otherwise = TyParen $ TyApp (TyCon $ UnQual $ Ident "Fix") (showFctr news f)
showType news (Data "Maybe" (K One :+!: K a)) = TyParen $ TyApp (TyCon $ Qual (ModuleName "Ori") (Ident "Maybe")) (showType news a)
showType news d@(Data n f) = TyCon $ Qual (ModuleName "Ori") (Ident n)
showType news (T.List a) = TyList $ showType news a
showType news a = TyCon $ UnQual $ Ident $ show a

showFctr :: [String] -> Fctr f -> Ext.Type
showFctr news I = TyCon $ UnQual $ Ident "Id"
showFctr news L = TyCon $ Special ListCon
showFctr news (K c) = TyParen $ TyApp (TyCon $ UnQual $ Ident "Const") (showType news c)
showFctr news (f :*!: g) = TyParen $ TyInfix (showFctr news f) (UnQual (Symbol ":*:")) (showFctr news g)
showFctr news (f :+!: g) = TyParen $ TyInfix (showFctr news f) (UnQual (Symbol ":+:")) (showFctr news g)
showFctr news (f :@!: g) = TyParen $ TyInfix (showFctr news f) (UnQual (Symbol ":@:")) (showFctr news g)

showAnn :: [String] -> T.Type a -> Exp
showAnn news a = Paren $ ExpTypeSig loc name (TyApp tann $ showType news a)
    where name = Var $ UnQual $ Ident "ann"
          tann = TyCon $ UnQual $ Ident "Ann"

showAnnFix :: [String] -> Fctr f -> Exp
showAnnFix news fctr = Paren $ ExpTypeSig loc name (TyApp tann $ TyApp tfix $ showFctr news fctr)
    where name = Var $ UnQual $ Ident "ann"
          tann = TyCon $ UnQual $ Ident "Ann"
          tfix = TyCon $ UnQual $ Ident "Fix"

showExp :: [String] -> T.Type a -> a -> Exp
showExp news (Pf _) (FMAP_LNS fctr (Fun x y) f) = Paren $ App (App name (showAnnFix news fctr)) arg 
    where name = Var $ UnQual $ Ident "fmap_lns"
          arg = showExp news (Pf $ Lns x y) f
showExp news (Pf _) (FMAP fctr (Fun x y) f) = Paren $ App (App name (showAnnFix news fctr)) arg 
    where name = Var $ UnQual $ Ident "fmap"
          arg = showExp news (Pf $ Fun x y) f
showExp news t@(Pf _) v@(COMP _ _ _) = Paren $ showCompExp news t v
showExp news t@(Pf _) v@(COMP_LNS _ _ _) = Paren $ showCompExp news t v
showExp news (Pf (Lns _ a)) INN_LNS = Paren $ App name (showAnn news a)
    where name = Var $ UnQual $ Ident "inn_lns'"
showExp news (Pf (Fun _ a)) INN = Paren $ App name (showAnn news a)
    where name = Var $ UnQual $ Ident "inn'"
showExp news (Pf (Lns a _)) OUT_LNS = Paren $ App name (showAnn news a)
    where name = Var $ UnQual $ Ident "out_lns'"
showExp news (Pf (Fun a _)) OUT = Paren $ App name (showAnn news a)
    where name = Var $ UnQual $ Ident "out'"
showExp news (Pf _) TOP = Var $ UnQual $ Ident "undefined"
showExp news (Pf (Fun a@(dataFctr -> Just f) b)) (CATA g) = Paren $ App (App name (showAnn news a)) gen 
    where name = Var $ UnQual $ Ident "cata"
          gen = showExp news (Pf $ Fun (rep f b) b) g
showExp news (Pf (Fun a@(dataFctr -> Just f) b)) (PARA g) = Paren $ App (App name (showAnn news a)) gen
    where name = Var $ UnQual $ Ident "para"
          gen = showExp news (Pf $ Fun (rep f (Prod b a)) b) g
showExp news (Pf (Fun a b@(dataFctr -> Just f))) (ANA g) = Paren $ App (App name (showAnn news b)) gen
    where name = Var $ UnQual $ Ident "ana"
          gen = showExp news (Pf $ Fun a (rep f a)) g
showExp news (Pf (Lns a@(dataFctr -> Just f) b)) (CATA_LNS g) = Paren $ App (App name (showAnn news a)) gen
    where name = Var $ UnQual $ Ident "cata_lns"
          gen = showExp news (Pf $ Lns (rep f b) b) g
showExp news (Pf (Lns a b@(dataFctr -> Just f))) (ANA_LNS g) = Paren $ App (App name (showAnn news b)) gen
    where name = Var $ UnQual $ Ident "ana_lns"
          gen = showExp news (Pf $ Lns a (rep f a)) g
showExp news a@(Data s f) v = Paren $ App (App name (showAnn news a)) (showExp news (rep f a) (out v))
    where name = Var $ UnQual $ Ident "inn'"
showExp news a@(NewData s f) v
    | s `elem`news = Paren $ App (App (Var $ UnQual $ Ident "inn'") (showAnn news a)) (showExp news (rep f a) (out v))
    | otherwise = Paren $ App (Var $ UnQual $ Ident "Inn") (showExp news (rep f a) (out v))
showExp news t x = showExpSpine news (toSpine t x)

showCompExp :: [String] -> T.Type a -> a -> Exp
showCompExp news (Pf (Fun a c)) (COMP b f g) = InfixApp (showCompExp news (Pf $ Fun b c) f) comp (showCompExp news (Pf $ Fun a b) g)
    where comp = QVarOp (UnQual (Symbol "."))
showCompExp news (Pf (Lns a c)) (COMP_LNS b f g) = InfixApp (showCompExp news (Pf $ Lns b c) f) comp (showCompExp news (Pf $ Lns a b) g)
    where comp = QVarOp (UnQual (Symbol ".<"))
showCompExp news t f = showExp news t f

showExpSpine :: [String] -> Spine a -> Exp
showExpSpine news (Ap f@(Ap (_ `As` c) (a :| x)) (b :| y))
    | fixity c == Infix = Paren $ InfixApp (showExp news a x) (QVarOp (UnQual (Symbol $ name c))) (showExp news b y)
    | otherwise = Paren $ App (showExpSpine news f) (showExp news b y)
showExpSpine news (_ `As` c) = Var $ UnQual $ Ident $ name c
showExpSpine news (Ap f (a :| x)) = Paren $ App (showExpSpine news f) (showExp news a x)

hsname :: String -> String
hsname "" = ""
hsname ('@':x:xs) = "Att" ++ toUpper x : xs
hsname (x:xs) = toUpper x : xs