module Derive.Show (deriveShow) where import List(intersperse,partition) import Maybe(isNothing,fromJust) import Syntax(Exp(ExpVar,ExpCon,ExpLit,ExpApplication,PatWildcard),Fun(Fun) ,Rhs(Unguarded),Alt(Alt),Decl(DeclFun,DeclInstance,DeclPat) ,Decls(DeclsParse),Boxed(Boxed),Lit(LitChar,LitString,LitInt)) import MkSyntax(mkInt) import IntState import IdKind import NT import State import Derive.Lib(syntaxType,syntaxCtxs) import TokenId(tTrue,tShow,tshowParen,tshowChar,tshowString ,tshowsType,tshowsPrec,t_lessthan,t_dot,dropM,isTidOp,visImport) import Nice(showsOp,showsVar) import Id(Id) deriveShow :: ((TokenId,IdKind) -> Id) -> Id -> Id -> [Id] -> [(Id,Id)] -> Pos -> a -> IntState -> (Decl Id,IntState) deriveShow tidFun cls typ tvs ctxs pos = getUnique >>>= \d -> let expD = ExpVar pos d ishowsPrec = tidFun (tshowsPrec,Method) ishowsType = tidFun (tshowsType,Method) expShowsPrec = ExpVar pos ishowsPrec expShowsType = ExpVar pos ishowsType expTrue = ExpCon pos (tidFun (tTrue,Con)) expShowString = ExpVar pos (tidFun (tshowString,Var)) expShowParen = ExpVar pos (tidFun (tshowParen,Var)) expShowSpace = ExpApplication pos [ExpVar pos (tidFun (tshowChar,Var)),ExpLit pos (LitChar Boxed ' ')] expLessThan = ExpVar pos (tidFun (t_lessthan,Var)) expDot = ExpVar pos (tidFun (t_dot,Var)) in getInfo typ >>>= \ typInfo -> mapS getInfo (constrsI typInfo) >>>= \ constrInfos -> addInstMethod tShow (tidI typInfo) tshowsPrec (NewType tvs [] ctxs [mkNTcons typ (map mkNTvar tvs)]) ishowsPrec >>>= \ fun -> addInstMethod tShow (tidI typInfo) tshowsType (NewType tvs [] ctxs [mkNTcons typ (map mkNTvar tvs)]) ishowsType >>>= \ funT -> mapS (mkShowFun expTrue expD expShowString expShowSpace expShowParen expShowsPrec expLessThan expDot pos) constrInfos >>>= \ funs -> mkShowFunTs expTrue expShowsType expShowParen expShowString expShowSpace expDot pos typInfo constrInfos >>>= \ funTs -> unitS $ DeclInstance pos (syntaxCtxs pos ctxs) cls [syntaxType pos typ tvs] $ DeclsParse [DeclFun pos fun funs ,DeclFun pos funT funTs] mkShowFun :: a -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Pos -> Info -> b -> IntState -> (Fun Id,IntState) mkShowFun expTrue expD expShowString expShowSpace expShowParen expShowsPrec expLessThan expDot pos constrInfo = let fields = fieldsI constrInfo conTid = dropM (tidI constrInfo) con = ExpCon pos (uniqueI constrInfo) expShowsConOp = ExpApplication pos [expShowString,ExpLit pos (LitString Boxed (showsOp conTid ""))] expShowsConVar = ExpApplication pos [expShowString,ExpLit pos (LitString Boxed (showsVar conTid ""))] in case ntI constrInfo of NewType _ _ _ [nt] -> -- This constructor has no arguments unitS (Fun [expD,con] (Unguarded expShowsConVar) (DeclsParse [])) NewType _ _ _ [a,b,r] | isTidOp conTid -> -- Infix constructor with two arguments getUnique >>>= \ v1 -> getUnique >>>= \ v2 -> let (lp,p,rp) = case fixityI constrInfo of (Infix,p) -> (p,p,p) (InfixR,p) -> (p+1,p,p) (_,p) -> (p,p,p+1) v1e = ExpVar pos v1 v2e = ExpVar pos v2 in unitS ( Fun [expD,ExpApplication pos [con,v1e,v2e]] (Unguarded (ExpApplication pos [expShowParen ,ExpApplication pos [expLessThan,mkInt pos p,expD] ,ExpApplication pos [expDot ,ExpApplication pos [expShowsPrec,mkInt pos lp,v1e] ,ExpApplication pos [expDot ,expShowSpace ,ExpApplication pos [expDot ,expShowsConOp ,ExpApplication pos [expDot ,expShowSpace ,ExpApplication pos [expShowsPrec,mkInt pos rp,v2e]]]]]] )) (DeclsParse [])) NewType _ _ _ (_:nts) | any isNothing fields -> -- We only want a list with one element for each argument, the elements themselves are never used mapS ( \ _ -> unitS (ExpVar pos) =>>> getUnique) nts >>>= \ args -> let exp10 = ExpLit pos (LitInt Boxed 10) exp9 = ExpLit pos (LitInt Boxed 9) expShowsPrec10 arg = ExpApplication pos [expShowsPrec,exp10,arg] in unitS ( Fun [expD,ExpApplication pos (con:args)] (Unguarded (ExpApplication pos [expShowParen ,ExpApplication pos [expLessThan,exp9,expD] ,foldl ( \ acc arg -> ExpApplication pos [expDot ,ExpApplication pos [expDot, acc ,expShowSpace] ,expShowsPrec10 arg]) expShowsConVar args ])) (DeclsParse [])) NewType _ _ _ (_:nts) -> -- named field labels must be shown mapS ( \ _ -> unitS (ExpVar pos) =>>> getUnique) nts >>>= \ args -> mapS (getInfo.fromJust) fields >>>= \ labels -> let exp10 = ExpLit pos (LitInt Boxed 10) exp9 = ExpLit pos (LitInt Boxed 9) expShowsPrec10 arg = ExpApplication pos [expShowsPrec,exp10,arg] expShowsLabel label = ExpApplication pos [expShowString ,ExpLit pos (LitString Boxed (showsVar (dropM (tidI label)) "="))] expShowsOpen = ExpApplication pos [expShowString,ExpLit pos (LitString Boxed "{")] expShowsClose = ExpApplication pos [expShowString,ExpLit pos (LitString Boxed "}")] expShowsComma = ExpApplication pos [expShowString,ExpLit pos (LitString Boxed ",")] in unitS ( Fun [expD,ExpApplication pos (con:args)] (Unguarded (ExpApplication pos [expShowParen ,ExpApplication pos [expLessThan,exp9,expD] ,( foldl (\acc item-> ExpApplication pos [expDot,acc,item]) expShowsConVar . (expShowsOpen:) . (++[expShowsClose]) . intersperse expShowsComma . zipWith (\label arg-> ExpApplication pos [expDot,expShowsLabel label, expShowsPrec10 arg]) labels ) args ])) -- ExpApplication pos [expDot, -- foldl ( \ acc (label,arg) -> -- ExpApplication pos [expDot, -- ExpApplication pos [expDot, acc , -- ExpApplication pos [expDot, expShowSpace, -- expShowsLabel label]], -- expShowsPrec10 arg]) -- (ExpApplication pos [expDot, expShowsConVar, expShowsOpen]) -- (zip (map tidI labels) args), -- expShowsClose]])] (DeclsParse [])) mkShowFunTs :: Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Exp Id -> Pos -> Info -> [Info] -> a -> IntState -> ([Fun Id],IntState) mkShowFunTs expTrue expShowsType expShowParen expShowString expShowSpace expDot pos typInfo constrInfos = getUnique >>>= \ v -> let expA = ExpVar pos v expTypeStr = ExpApplication pos [expShowString,(ExpLit pos . LitString Boxed . show . dropM . tidI) typInfo] in case ntI typInfo of NewType [] [] [] _ -> unitS [Fun [expA] (Unguarded expTypeStr) (DeclsParse [])] NewType free exist _ _ -> mapS (\ f -> getUnique >>>= \ i -> unitS (f,i,ExpVar pos i)) free >>>= \ fitypes -> mapS0 (\(f,i,ei)-> addNewLetBound i (visImport ('v':(show i)))) fitypes >>> mapS ( getType pos expA expShowsType expTrue expShowString constrInfos ) fitypes >>>= \ des -> case unzip des of (ds,es) -> unitS [Fun [expA] (Unguarded (ExpApplication pos [expShowParen ,expTrue ,foldl ( \ acc e -> ExpApplication pos [expDot ,ExpApplication pos [expDot, acc ,expShowSpace] ,e]) expTypeStr es])) (DeclsParse (concat ds)) ] getType :: Show a => Pos -> Exp Id -> Exp Id -> b -> Exp Id -> [Info] -> (Id,a,Exp Id) -> c -> d -> (([Decl Id],Exp Id),d) getType pos expA expShowsType expTrue expShowString [] (f,i,iexp) = unitS ([],ExpApplication pos [expShowString,ExpLit pos (LitString Boxed ('?':'v':show i++"?"))]) getType pos expA expShowsType expTrue expShowString (info:infos) (f,i,iexp) = patConstr pos info f iexp >>>= \ qpat -> case qpat of Just pat -> unitS ([DeclPat (Alt pat (Unguarded expA) (DeclsParse[]))] ,ExpApplication pos [expShowsType,iexp]) Nothing -> getType pos expA expShowsType expTrue expShowString infos (f,i,iexp) patConstr :: Pos -> Info -> Id -> Exp Id -> a -> b -> (Maybe (Exp Id),b) patConstr pos info f iexp = case ntI info of NewType free exist ctxs nts -> let ints = (zip [0 .. ] . init) nts in case (partition (simpleNT . snd) . filter (elem f . freeNT . snd)) ints of ([],[]) -> unitS Nothing ((i,nt):_,_) -> unitS (Just (ExpApplication pos (ExpCon pos (uniqueI info) : map (toExp i iexp) ints))) ([],xs) -> unitS Nothing -- can do better here !! where toExp i iexp (i',_) = if i == i' then iexp else PatWildcard pos simpleNT :: NT -> Bool simpleNT (NTstrict nt) = simpleNT nt simpleNT (NTvar v _) = True simpleNT (NTany v) = True simpleNT _ = False