{- ---------------------------------------------------------------------------
Make parts of Haskell syntax tree
-}
module MkSyntax
	( mkAppExp, mkAppInst, mkCase, mkDeclClass
	, mkDeclFun, mkDeclPat, mkDeclPatFun, mkEnumFrom
	, mkEnumThenFrom, mkEnumToFrom, mkEnumToThenFrom
        , mkLambda, mkLet, mkDo, mkFieldExp,mkExpList
	, mkExpListComp, mkIf, mkInfixList
	, mkInstList, mkInt, mkParExp, mkParInst, mkParType
	, mkTypeList, mkPatNplusK, mkParLhs
	) where

import Extra(Pos,noPos,mergePos,mergePoss)
import TokenId
import Syntax
import SyntaxPos(HasPos(getPos))


mkParType :: Pos -> [Type TokenId] -> Type TokenId
mkParType p [t] = t
mkParType p ts  = TypeCons p (t_Tuple (length ts)) ts


mkAppInst :: (Pos,a) -> [(Pos,a)] -> Type a
mkAppInst (p,c) ts = TypeCons p c (map (uncurry TypeVar) ts)


mkInfixList [e] = e
mkInfixList es = ExpInfixList (getPos es) es


mkParInst p [t] = error ("mkParInst on singleton list")
mkParInst p ts  = TypeCons p (t_Tuple (length ts)) (map (uncurry TypeVar) ts)


mkInstList p id = TypeCons p t_List [TypeVar p id]


mkDeclPat :: (Pos,a) -> Exp a -> Exp a -> Rhs a -> Decls a -> Decl a
mkDeclPat (pv,var) op e@(ExpInfixList pos es) gdexps w =
	DeclPat (Alt (ExpInfixList pos [ExpVar pv var,op,e]) gdexps w)
mkDeclPat (pv,var) op e gdexps w =
	DeclPat (Alt (ExpInfixList pv [ExpVar pv var,op,e]) gdexps w)


mkDeclFun :: (Pos,a) -> [Pat a] -> Rhs a -> Decls a -> Decl a
--mkDeclFun (pv,var) [] gdexps w =
--	DeclPat (Alt (ExpVar pv var) gdexps w)
mkDeclFun (pv,var) pats gdexps w =
  DeclFun (mergePoss [pv `min` getPos pats,getPos gdexps,getPos w]) 
    var [Fun pats gdexps w]


mkDeclPatFun :: Alt a -> Decl a
mkDeclPatFun  (Alt (ExpVar pos fun) gdexps w) =
  DeclFun (mergePoss [pos,getPos gdexps,getPos w]) fun [Fun [] gdexps w]
--        DeclPat (Alt (ExpVar pos fun) gdexps w)
mkDeclPatFun  (Alt (ExpInfixList _ [ExpVar pos fun]) gdexps w) =
  DeclFun (mergePoss [pos,getPos gdexps,getPos w]) fun [Fun [] gdexps w]
mkDeclPatFun  (Alt (ExpInfixList _ (ExpVar pos fun:qop:args)) gdexps w) 
  | notOp qop = DeclFun (mergePoss [pos,getPos gdexps,getPos w]) fun 
                  [Fun (qop:args) gdexps w]
mkDeclPatFun alt = DeclPat alt

notOp (ExpConOp _ _) = False
notOp (ExpVarOp _ _) = False
notOp _ = True

--mkRevTypeArrow p a b = TypeCons p t_Arrow [b,a]
mkTypeList p t = TypeCons p t_List [t]

-- passes position of lambda
mkLambda pos pats e = 
  let p = mergePos pos (getPos e) in p `seq` ExpLambda p pats e

-- passes position of let
mkLet pos decls e =
  let p = mergePos pos (getPos e) in p `seq` ExpLet p decls e

-- passes position of do
mkDo pos stmts =
  let p = mergePos pos (getPos stmts) in p `seq` ExpDo p stmts

-- passes position of if
mkIf pos e1 e2 e3 =
  let p = mergePos pos (getPos e3) in p `seq` ExpIf p e1 e2 e3

-- passes position of case
mkCase pos e alts =
  let p = mergePos pos (getPos alts) in p `seq` ExpCase p e alts


mkEnumFrom pos eFrom =
        ExpApplication pos [ExpVar pos tenumFrom,eFrom]
mkEnumToFrom pos eTo eFrom =
        ExpApplication pos [ExpVar pos tenumFromTo,eFrom,eTo]
mkEnumThenFrom pos eThen eFrom =
        ExpApplication pos [ExpVar pos tenumFromThen,eFrom,eThen]
mkEnumToThenFrom pos eTo eThen eFrom =
        ExpApplication pos [ExpVar pos tenumFromThenTo,eFrom,eThen,eTo]


mkAppExp [] = error "mkAppExp"
mkAppExp [e] = e
mkAppExp es@[e1,e2] = 
  ExpApplication (mergePos (getPos e1) (getPos e2)) es
mkAppExp es@(e1:e2:es') =
  ExpApplication (mergePos (min (getPos e1) (getPos e2)) (getPos (last es'))) 
    es
  -- operator of infix expression is in front and first argument next

-- passes positions of left and right parenthesis
mkParExp posl [ExpConOp pos' id] posr = ExpCon pos' id
mkParExp posl [ExpVarOp pos' id] posr = ExpVar pos' id
mkParExp posl [e] posr = e
mkParExp posl es  posr = 
  let p = mergePos posl posr 
  in p `seq` ExpApplication p (ExpCon p (t_Tuple (length es)):es)

mkFieldExp pos ident exp =
  let p = mergePos pos (getPos exp) in p `seq` FieldExp pos ident exp

-- passes positions of left and right brackets
mkExpList posl exps posr =
  let p = mergePos posl posr in p `seq` ExpList p exps

mkParLhs pos app args = ExpApplication pos (app:args)

-- combineGroups (DeclsParse d1) (DeclsParse d2) = DeclsParse (d1++d2)
-- 
-- mkDeclClass ctx (pos,cls) (_,arg) (csigns,valdefs) =
--             DeclClass pos ctx cls arg (combineGroups csigns valdefs)

-- changed in H98 to:
mkDeclClass ctx (pos,cls) posargs fundeps cdecls =
    DeclClass pos ctx cls (map snd posargs) fundeps cdecls


mkExp_Colon :: Pos -> Exp TokenId
mkExp_Colon pos  = ExpCon pos t_Colon

mkExp_filter :: Pos -> Exp TokenId
mkExp_filter pos  = ExpVar pos t_filter

mkExp_foldr :: Pos -> Exp TokenId
mkExp_foldr pos  = ExpVar pos t_foldr

mkExp_x :: Pos -> Exp TokenId
mkExp_x pos  = ExpVar pos t_x
mkExp_y :: Pos -> Exp TokenId
mkExp_y pos  = ExpVar pos t_y


mkExpListComp pos qs e = ExpApplication noPos [trans pos qs e,ExpList noPos []]
 where
  trans pos [] e =
    ExpApplication pos
        [mkExp_Colon pos
        ,e
        ]
  trans pos (QualLet decls:qs) e =
    ExpLet pos decls (trans pos qs e)
  trans pos (QualExp exp:qs) e =
    ExpApplication pos
        [mkExp_filter pos
        ,exp
        ,trans pos qs e
        ]
  trans pos (QualPatExp pat exp:qs) e =
    ExpApplication pos
        [mkExp_foldr pos
        ,ExpLambda pos
            [mkExp_x noPos,mkExp_y pos]
            (ExpCase noPos (mkExp_x pos)
              [Alt pat
                   (Unguarded (ExpApplication pos [trans pos qs e,mkExp_y pos]))
                   (DeclsParse [])
              ,Alt (PatWildcard pos)
                   (Unguarded (mkExp_y pos))
                   (DeclsParse [])
              ]
            )
        ,exp
        ]


mkInt pos i = ExpLit pos (LitInt Boxed i)

mkPatNplusK (pos,tid) (posi,integer) =
  let p = mergePos pos posi in p `seq` 
    PatNplusK p tid undefined (ExpLit posi integer) undefined undefined
-- While parsing (n+k), can't choose a unique replacement identifier n',
-- so leave some fields to be filled in later.

--  let k = ExpLit posi integer in
--  PatNplusK pos tid undefined k (ExpApplication pos [t_lessequal,k])
--                                (ExpApplication pos [t_subtract,k])

{- End Module MkSyntax ------------------------------------------------------}