DeriveRead

module DeriveRead(deriveRead) where

import Maybe
import Extra
import Syntax
import MkSyntax(mkInt)
import IntState
import IdKind
import NT
import State
import DeriveLib
import TokenId(TokenId,tFalse,tTrue,tRead,treadParen,treadsPrec
              ,t_greater,t_append,t_readCon0,t_readCon,t_readConArg
              ,t_readConInfix,t_readField,t_readFinal,isTidOp,dropM)
import Nice(showsOp,showsVar)

deriveRead tidFun cls typ tvs ctxs pos =
 getUnique >>>= \ d ->
 getUnique >>>= \ r ->
 let expD = ExpVar pos d
     expR = ExpVar pos r
     ireadsPrec = tidFun (treadsPrec,Method)
     expTrue = ExpCon pos (tidFun (tTrue,Con))
     expAppend = ExpVar pos (tidFun (t_append,Var))
 in
  getInfo typ >>>= \ typInfo -> 
  mapS getInfo (constrsI typInfo) >>>= \ constrInfos ->
  addInstMethod tRead (tidI typInfo) treadsPrec (NewType tvs [] ctxs [NTcons typ (map NTvar tvs)]) ireadsPrec >>>= \ fun ->
  mapS (mkReadExp expD expR tidFun pos) constrInfos >>>= \ (e:es) ->
  unitS $
    DeclInstance pos (syntaxCtxs pos ctxs) cls (syntaxType pos typ tvs) $
      DeclsParse [DeclFun pos fun 
	[Fun [expD,expR]
	  (Unguarded 
            (foldr (\ e1 e2 -> ExpApplication pos [expAppend, e1, e2]) e es)) 
          (DeclsParse [])]
		]



mkReadExp expD expR tidFun pos constrInfo =
  let 
      conTid = dropM (tidI constrInfo)      
      con = ExpCon pos (uniqueI constrInfo)
      fields = fieldsI constrInfo
  in
    if isTidOp conTid then
      let expConOp = ExpLit pos (LitString Boxed (showsOp conTid ""))
          expTrue = ExpCon pos (tidFun (tTrue,Con))
      in 
	case ntI constrInfo of
	  NewType _ _ _ [nt] -> -- This constructor has no arguments
	    unitS (ExpApplication pos [ExpVar pos (tidFun (t_readCon0,Var)), expTrue, con, expConOp, expR])
	  NewType _ _ _ [a,b,r] -> -- Infix constructor with two arguments
	    let (p,lp,rp) = case fixityI constrInfo of
			       (Infix,p)  -> (p,p+1,p+1)
			       (InfixR,p) -> (p,p+1,p)
			       (_,p)      -> (p,p,p+1)
	    in unitS (ExpApplication pos [ExpVar pos (tidFun (t_readConInfix,Var)) ,expD ,(mkInt pos p) ,(mkInt pos lp) ,(mkInt pos rp) ,con ,expConOp, expR])
	  NewType _ _ _ (_:nts) ->  -- We only want a list with one element for each argument, the elements themselves are never used
	    let readConArg = ExpVar pos (tidFun (t_readConArg,Var))
	    in unitS $
		 ExpApplication pos [ExpVar pos (tidFun (treadParen,Var))
				      ,ExpApplication pos [ExpVar pos (tidFun (t_greater,Var)), expD, mkInt pos 9]
				      ,foldr (\ _ a -> ExpApplication pos [readConArg,a])
					     (ExpApplication pos [ExpVar pos (tidFun (t_readCon0,Var)), expTrue, con, expConOp]) 
					     nts
				      ,expR]

    else if null fields || any isNothing fields	-- ordinary constructor
    then
      let expConVar = ExpLit pos (LitString Boxed (showsVar conTid ""))
          expFalse = ExpCon pos (tidFun (tFalse,Con))
      in
	case ntI constrInfo of
	  NewType _ _ _ [nt] -> -- This constructor has no arguments
	    unitS (ExpApplication pos [ExpVar pos (tidFun (t_readCon0,Var)), expFalse, con, expConVar, expR])
	  NewType _ _ _ (_:nts) ->  -- We only want a list with one element for each argument, the elements themselves are never used
	    let readConArg = ExpVar pos (tidFun (t_readConArg,Var))
	    in unitS $
		 ExpApplication pos [ExpVar pos (tidFun (treadParen,Var))
				      ,ExpApplication pos [ExpVar pos (tidFun (t_greater,Var)), expD, mkInt pos 9]
				      ,foldr (\ _ a -> ExpApplication pos [readConArg,a])
					     (ExpApplication pos [ExpVar pos (tidFun (t_readCon,Var)), con, expConVar]) 
					     nts
				      ,expR]

    else	-- constructor with named fields
      let expConVar = ExpLit pos (LitString Boxed (showsVar conTid ""))
          expFalse = ExpCon pos (tidFun (tFalse,Con))
          expReadField = ExpVar pos (tidFun (t_readField,Var))
          expReadFinal k = ExpApplication pos
              [ExpVar pos (tidFun (t_readFinal,Var))
              ,ExpLit pos (LitString Boxed "}")
              ,k]
          expLabel prefix label k = ExpApplication pos
              [expReadField
              ,ExpLit pos (LitString Boxed prefix)
              ,ExpLit pos (LitString Boxed (showsVar (dropM (tidI label)) ""))
              ,k]
	  (NewType _ _ _ (_:nts)) = ntI constrInfo -- get list, 1 elem per arg
	  readConArg = ExpVar pos (tidFun (t_readConArg,Var))
          prefixes = "{": replicate (length nts - 1) ","
      in
        mapS (getInfo.fromJust) fields >>>= \labels->
        unitS $
	  ExpApplication pos
              [ExpVar pos (tidFun (treadParen,Var))
	      ,ExpApplication pos
                  [ExpVar pos (tidFun (t_greater,Var)), expD, mkInt pos 9]
              ,expReadFinal
                  (foldr (\(p,l) a -> expLabel p l a)
                         (ExpApplication pos
                             [ExpVar pos (tidFun (t_readCon,Var))
                             ,con ,expConVar])
                         (reverse (zip prefixes labels)))
              ,expR]