module GF.Devel.Grammar.Macros where

import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Modules
import GF.Infra.Ident

import GF.Data.Operations

import qualified Data.Map as Map
import Control.Monad (liftM,liftM2)


-- analyse types and terms

contextOfType :: Type -> Context
contextOfType ty = co where (co,_,_) = typeForm ty

typeForm :: Type -> (Context,Term,[Term])
typeForm t = (co,f,a) where
  (co,t2) = prodForm t
  (f,a) = appForm t2

prodForm :: Type -> (Context,Term)
prodForm t = case t of
  Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val
  _ -> ([],t)

appForm :: Term -> (Term,[Term])
appForm tr = (f,reverse xs) where 
  (f,xs) = apps tr
  apps t = case t of
    App f a -> (f2,a:a2) where (f2,a2) = appForm f
    _ -> (t,[])

valCat :: Type -> Err (Ident,Ident)
valCat typ = case typeForm typ of
  (_,Q m c,_) -> return (m,c)

typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
typeRawSkeleton typ = do
  let (cont,typ) = prodForm typ
  args <- mapM (typeRawSkeleton . snd) cont
  return ([(length c, v) | (c,v) <- args], typ)

type MCat = (Ident,Ident)

sortMCat :: String -> MCat
sortMCat s = (identC "_", identC s)

--- hack for Editing.actCat in empty state
errorCat :: MCat
errorCat = (identC "?", identC "?")

getMCat :: Term -> Err MCat
getMCat t = case t of
  Q  m c -> return (m,c)
  QC m c -> return (m,c)
  Sort s -> return $ sortMCat s
  App f _ -> getMCat f
  _ -> error $ "no qualified constant" +++ show t

typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do
  (cont,val) <- typeRawSkeleton typ
  cont' <- mapPairsM getMCat cont
  val'  <- getMCat val
  return (cont',val')

-- construct types and terms

mkProd :: Context -> Type -> Type
mkProd = flip (foldr (uncurry Prod))

mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod

mkApp :: Term -> [Term] -> Term
mkApp = foldl App

mkAbs :: [Ident] -> Term -> Term
mkAbs xs t = foldr Abs t xs

mkCTable :: [Ident] -> Term -> Term
mkCTable ids v = foldr ccase v ids where 
  ccase x t = T TRaw [(PV x,t)]

appCons :: Ident -> [Term] -> Term
appCons = mkApp . Con

appc :: String -> [Term] -> Term
appc = appCons . identC

tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]

tuple2recordType :: [Term] -> [Labelling]
tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]

tuple2recordPatt :: [Patt] -> [(Label,Patt)]
tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]

tupleLabel :: Int -> Label
tupleLabel i = LIdent $ "p" ++ show i

assign :: Label -> Term -> Assign
assign l t = (l,(Nothing,t))

assignT :: Label -> Type -> Term -> Assign
assignT l a t = (l,(Just a,t))

mkDecl :: Term -> Decl
mkDecl typ = (wildIdent, typ)

mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs

mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]

mkRecType :: (Int -> Label) -> [Type] -> Type
mkRecType = mkRecTypeN 0

plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of
  (RecType r1, RecType r2) -> case
    filter (`elem` (map fst r1)) (map fst r2) of
      [] -> return (RecType (r1 ++ r2))
      ls -> Bad $ "clashing labels" +++ unwords (map show ls)
  _ -> Bad ("cannot add record types" +++ show t1 +++ "and" +++ show t2) 

plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
 case (t1,t2) of
   (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
                              (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
   (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
   (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
   _ -> Bad ("cannot add records" +++ show t1 +++ "and" +++ show t2)

zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]

-- type constants

typeType :: Type
typeType = Sort "Type"

typePType :: Type
typePType = Sort "PType"

typeStr :: Type
typeStr = Sort "Str"

cPredef :: Ident
cPredef = identC "Predef"

cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"

typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term

typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)

isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
  App c _ -> c == constPredefRes "Ints"
  _ -> False

constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (identC s)

isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
  Q (IC "Predef") _ -> True
  Q (IC "PredefAbs") _ -> True
  _ -> False

defLinType :: Type
defLinType = RecType [(LIdent "s",  typeStr)]

meta0 :: Term
meta0 = Meta 0

ident2label :: Ident -> Label
ident2label c = LIdent (prIdent c)

label2ident :: Label -> Ident
label2ident (LIdent c) = identC c

----label2ident :: Label -> Ident
----label2ident = identC . prLabel

-- to apply a term operation to every term in a judgement, module, grammar

termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF
termOpGF f g = do 
  ms <- mapMapM fm (gfmodules g)
  return g {gfmodules = ms}
 where
   fm = termOpModule f

termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module
termOpModule f = judgementOpModule fj where
  fj = termOpJudgement f
   
judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module
judgementOpModule f m = do 
  mjs <- mapMapM fj (mjments m)
  return m {mjments = mjs}
 where
  fj = either (liftM Left . f) (return . Right)
   
termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
termOpJudgement f j = do 
  jtyp <- f (jtype j)
  jde <- f (jdef j)
  jpri <- f (jprintname j)
  return $ j {
    jtype = jtyp,
    jdef = jde,
    jprintname = jpri
    }

-- | to define compositional term functions
composSafeOp :: (Term -> Term) -> Term -> Term
composSafeOp op trm = case composOp (mkMonadic op) trm of
  Ok t -> t
  _ -> error "the operation is safe isn't it ?"
 where
 mkMonadic f = return . f

-- | to define compositional monadic term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm = case trm of
   App c a -> 
     do c' <- co c
        a' <- co a
        return (App c' a')
   Abs x b ->
     do b' <- co b
        return (Abs x b')
   Prod x a b -> 
     do a' <- co a
        b' <- co b
        return (Prod x a' b')
   S c a -> 
     do c' <- co c
        a' <- co a
        return (S c' a')
   Table a c -> 
     do a' <- co a
        c' <- co c
        return (Table a' c')
   R r -> 
     do r' <- mapAssignM co r
        return (R r')
   RecType r -> 
     do r' <- mapPairListM (co . snd) r
        return (RecType r')
   P t i ->
     do t' <- co t
        return (P t' i)
   PI t i j ->
     do t' <- co t
        return (PI t' i j)
   ExtR a c -> 
     do a' <- co a
        c' <- co c
        return (ExtR a' c')
   T i cc -> 
     do cc' <- mapPairListM (co . snd) cc
        i'  <- changeTableType co i
        return (T i' cc')
   Eqs cc -> 
     do cc' <- mapPairListM (co . snd) cc
        return (Eqs cc')
   V ty vs ->
     do ty' <- co ty
        vs' <- mapM co vs
        return (V ty' vs')
   Let (x,(mt,a)) b -> 
     do a'  <- co a
        mt' <- case mt of
                 Just t -> co t >>= (return . Just) 
                 _ -> return mt
        b'  <- co b
        return (Let (x,(mt',a')) b')
   C s1 s2 -> 
     do v1 <- co s1 
        v2 <- co s2
        return (C v1 v2)
   Glue s1 s2 -> 
     do v1 <- co s1
        v2 <- co s2
        return (Glue v1 v2)
   Alts (t,aa) ->
     do t' <- co t
        aa' <- mapM (pairM co) aa
        return (Alts (t',aa'))
   FV ts -> mapM co ts >>= return . FV
   Overload tts -> do
     tts' <- mapM (pairM co) tts
     return $ Overload tts'

   _ -> return trm -- covers K, Vr, Cn, Sort


---- should redefine using composOp
collectOp :: (Term -> [a]) -> Term -> [a]
collectOp co trm = case trm of
  App c a    -> co c ++ co a 
  Abs _ b    -> co b
  Prod _ a b -> co a ++ co b 
  S c a      -> co c ++ co a
  Table a c  -> co a ++ co c
  ExtR a c   -> co a ++ co c
  R r        -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r 
  RecType r  -> concatMap (co . snd) r 
  P t i      -> co t
  T _ cc     -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
  V _ cc     -> concatMap co         cc --- nor from type annot
  Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
  C s1 s2    -> co s1 ++ co s2 
  Glue s1 s2 -> co s1 ++ co s2 
  Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
  FV ts      -> concatMap co ts
  _ -> [] -- covers K, Vr, Cn, Sort, Ready

--- just aux to composOp?

mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
  where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)

changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
changeTableType co i = case i of
    TTyped ty -> co ty >>= return . TTyped
    TComp ty  -> co ty >>= return . TComp
    TWild ty  -> co ty >>= return . TWild
    _ -> return i


patt2term :: Patt -> Term
patt2term pt = case pt of
  PV x      -> Vr x
  PW        -> Vr wildIdent             --- not parsable, should not occur
  PC c pp   -> mkApp (Con c) (map patt2term pp)
  PP p c pp -> mkApp (QC p c) (map patt2term pp)
  PR r      -> R [assign l (patt2term p) | (l,p) <- r] 
  PT _ p    -> patt2term p
  PInt i    -> EInt i
  PFloat i  -> EFloat i
  PString s -> K s 

  PAs x p   -> appc "@" [Vr x, patt2term p]            --- an encoding
  PSeq a b  -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
  PAlt a b  -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
  PRep a    -> appc "*" [(patt2term a)]                --- an encoding
  PNeg a    -> appc "-" [(patt2term a)]                --- an encoding


---- given in lib?

mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v)
mapMapM f = 
  liftM Map.fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . Map.assocs