{-# OPTIONS_GHC -fglasgow-exts -fth -cpp #-}
module Emit.PIR.ParrotObject where

import Data.Char
import Emit.PIR
import Emit.Common
import Language.Haskell.TH.Syntax

type CnName = String
type Ty = String
data Cn = MkCn CnName [Ty]

genClass :: Ty -> [Cn] -> PIR
genClass ty cons = (genTy ty ++ concatMap (genCn ty) cons)

genNS :: Ty -> [Decl] -> Decl
genNS = DeclNS . genLit

genLit :: Ty -> String
genLit = ("PIR::" ++)

genTy :: Ty -> PIR
genTy ty =
    [ genNS ty
        [ DeclSub "__onload" [SubMETHOD] $ map StmtIns
            [ tempPMC <-- "newclass" $ [lit $ genLit ty]
            ]
        ]
    ]

genCn :: Ty -> Cn -> PIR
genCn ty (MkCn con tys) =
    [ genNS con
        [ DeclSub "__onload" [SubMETHOD] $ map StmtIns
            [ tempPMC <-- "subclass" $ [tempPMC, (lit $ genLit ty), fullTy]
            , tempPMC <-- "getclass" $ [fullTy]
            ] ++
            [ StmtIns $ "addattribute" .- [tempPMC, fullNum num]
            | (num, _) <- [1..] `zip` tys
            ]
        , DeclSub "__init" [SubMETHOD] $
            map StmtIns (concatMap fullArg ([1..] `zip` tys))
        ]
    ]
    where
    fullNum :: Int -> Expression
    fullNum num = lit ('$':'.':show num)
    fullTy = lit $ genLit (ty ++ "::" ++ con)
    fullArg (num, attr) = 
        [ InsNew tempPMC (bareType attr)
        , "setattribute" .- [bare "self", fullNum num, tempPMC]
        ]

bareType :: String -> ObjType
bareType t@('G':'H':'C':'.':_) = BareType $ reverse (takeWhile isAlphaNum (reverse t))
bareType t = BareType ("PIR::" ++ t)

genDec :: Dec -> PIR
genDec (DataD _ ty _ cons _) = genClass (show ty) (map conToCn cons)
genDec x = error $ show x

conToCn :: Con -> Cn
conToCn (NormalC con args) = MkCn (show con) (map (argToTy . snd) args)
conToCn x = error $ show x

argToTy :: Type -> Ty
argToTy (ConT x) = show x
argToTy (AppT ListT (ConT x)) = (show x) ++ "List"
argToTy x = error (show x)
    
test :: IO ()
test = do
    q <- runQ decls
    writeFile "pir.pir" (show $ emit $ concatMap genDec q)
    putStrLn "*** File saved as pir.pir"
    return ()

#ifndef HADDOCK
decls :: Q [Dec]
decls = [d|

    data Decl
        = DeclSub       String [SubFlag] [Stmt]
        | DeclNS        String [Decl]
        | DeclInc       FilePath
    data Stmt
        = StmtComment   String
        | StmtLine      FilePath Int
        | StmtPad       [String] [Stmt]
        | StmtIns       Ins

    data Ins
        = InsLocal      RegType String
        | InsNew        LValue ObjType
        | InsBind       LValue Expression
        | InsAssign     LValue Expression
        | InsPrim       LValue String [Expression]
        | InsFun        [Sig] Expression [Expression]
        | InsTailFun    Expression [Expression]
        | InsLabel      String
        | InsComment    String Ins
        | InsExp        Expression

    data Expression
        = ExpLV LValue
        | ExpLit Literal

    data LValue
        = VAR String
        | PMC Int
        | STR Int
        | INT Int
        | NUM Int
        | KEYED LValue Expression
        | NULL

    data Literal
        = LitStr String
        | LitInt Integer
        | LitNum Double

    data SubFlag
        = SubMAIN
        | SubLOAD
        | SubANON
        | SubMETHOD
        | SubMULTI [ObjType]

    data RegType
        = RegInt
        | RegNum
        | RegStr
        | RegPMC

    data ObjType
        = PerlScalar
        | PerlList
        | PerlHash
        | PerlInt
        | PerlPair
        | PerlRef
        | PerlEnv

    data Sig
        = MkSig [ArgFlag] Expression

    data ArgFlag
        = MkArgFlatten 
        | MkArgSlurpyArray
        | MkArgMaybeFlatten
        | MkArgOptional

    |]
#endif