Macros.hs

module GF.Grammar.Macros where

import GF.Data.Operations
import GF.Data.Str
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Predef
import GF.Grammar.Printer

import Control.Monad.Identity(Identity(..))
import qualified Data.Traversable as T(mapM)
import qualified Data.Map as Map
import Control.Monad (liftM, liftM2, liftM3)
import Data.List (sortBy,nub)
import Data.Monoid
import GF.Text.Pretty(render,(<+>),hsep,fsep)
import qualified Control.Monad.Fail as Fail

-- ** Functions for constructing and analysing source code terms.

typeForm :: Type -> (Context, Cat, [Term])
typeForm t =
  case t of
    Prod b x a t  ->
      let (x', cat, args) = typeForm t
      in ((b,x,a):x', cat, args)
    App c a ->
      let (_,  cat, args) = typeForm c
      in ([],cat,args ++ [a])
    Q  c -> ([],c,[])
    QC c -> ([],c,[])
    Sort c -> ([],(MN identW, c),[])
    _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))

typeFormCnc :: Type -> (Context, Type)
typeFormCnc t =
  case t of
    Prod b x a t -> let (x', v) = typeFormCnc t
                    in ((b,x,a):x',v)
    _            -> ([],t)

valCat :: Type -> Cat
valCat typ =
  let (_,cat,_) = typeForm typ
  in cat

valType :: Type -> Type
valType typ =
  let (_,cat,xx) = typeForm typ --- not optimal to do in this way
  in mkApp (Q cat) xx

valTypeCnc :: Type -> Type
valTypeCnc typ = snd (typeFormCnc typ)

typeSkeleton :: Type -> ([(Int,Cat)],Cat)
typeSkeleton typ =
  let (ctxt,cat,_) = typeForm typ
  in ([(length c, v) | (b,x,t) <- ctxt, let (c,v) = typeSkeleton t], cat)

catSkeleton :: Type -> ([Cat],Cat)
catSkeleton typ =
  let (args,val) = typeSkeleton typ
  in (map snd args, val)

funsToAndFrom :: Type -> (Cat, [(Cat,[Int])])
funsToAndFrom t =
  let (cs,v) = catSkeleton t
      cis = zip cs [0..]
  in (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])

isRecursiveType :: Type -> Bool
isRecursiveType t =
  let (cc,c) = catSkeleton t -- thus recursivity on Cat level
  in any (== c) cc

isHigherOrderType :: Type -> Bool
isHigherOrderType t = fromErr True $ do  -- pessimistic choice
  co <- contextOfType t
  return $ not $ null [x | (_,x,Prod _ _ _ _) <- co]

contextOfType :: Monad m => Type -> m Context
contextOfType typ = case typ of
  Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
  _            -> return []

termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
termForm t = case t of
   Abs b x t  ->
     do (x', fun, args) <- termForm t
        return ((b,x):x', fun, args)
   App c a ->
     do (_,fun, args) <- termForm c
        return ([],fun,args ++ [a])
   _       ->
     return ([],t,[])

termFormCnc :: Term -> ([(BindType,Ident)], Term)
termFormCnc t = case t of
   Abs b x t  -> ((b,x):xs, t') where (xs,t') = termFormCnc t
   _          -> ([],t)

appForm :: Term -> (Term, [Term])
appForm t = case t of
  App c a   -> (fun, args ++ [a]) where (fun, args) = appForm c
  Typed t _ -> appForm t
  _         -> (t,[])

mkProdSimple :: Context -> Term -> Term
mkProdSimple c t = mkProd c t []

mkProd :: Context -> Term -> [Term] -> Term
mkProd []           typ args = mkApp typ args
mkProd ((b,x,a):dd) typ args = Prod b x a (mkProd dd typ args)

mkTerm :: ([(BindType,Ident)], Term, [Term]) -> Term
mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)

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

mkAbs :: [(BindType,Ident)] -> Term -> Term
mkAbs xx t = foldr (uncurry Abs) t xx

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

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

mkLetUntyped :: Context -> Term -> Term
mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (_,x,t) <- defs]

isVariable :: Term -> Bool
isVariable (Vr _ ) = True
isVariable _ = False

--eqIdent :: Ident -&gt; Ident -&gt; Bool
--eqIdent = (==)

uType :: Type
uType = Cn cUndefinedType

-- *** Assignment

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

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

unzipR :: [Assign] -> ([Label],[Term])
unzipR r = (ls, map snd ts) where (ls,ts) = unzip r

mkAssign :: [(Label,Term)] -> [Assign]
mkAssign lts = [assign l t | (l,t) <- lts]

projectRec :: Label -> [Assign] -> Term
projectRec l rs =
  case lookup l rs of
    Just (_,t) -> t
    Nothing    -> error (render ("no value for label" <+> l))

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

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)

-- *** Records

mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]

mkRecord :: (Int -> Label) -> [Term] -> Term
mkRecord = mkRecordN 0

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

record2subst :: Term -> Err Substitution
record2subst t = case t of
  R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
  _    -> Bad (render ("record expected, found" <+> ppTerm Unqualified 0 t))


-- *** Types

typeType, typePType, typeStr, typeTok, typeStrs :: Type

typeType  = Sort cType
typePType = Sort cPType
typeStr   = Sort cStr
typeTok   = Sort cTok
typeStrs  = Sort cStrs

typeString, typeFloat, typeInt :: Type
typeInts :: Int -> Type
typePBool :: Type
typeError :: Type

typeString = cnPredef cString
typeInt = cnPredef cInt
typeFloat = cnPredef cFloat
typeInts i = App (cnPredef cInts) (EInt i)
typePBool = cnPredef cPBool
typeError = cnPredef cErrorType

isTypeInts :: Type -> Maybe Int
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
isTypeInts _                                      = Nothing

-- *** Terms

isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
  Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
  _                                               -> False

checkPredefError :: Fail.MonadFail m => Term -> m Term
checkPredefError t =
    case t of
      Error s -> fail ("Error: "++s)
      _ -> return t

cnPredef :: Ident -> Term
cnPredef f = Q (cPredef,f)

mkSelects :: Term -> [Term] -> Term
mkSelects t tt = foldl S t tt

mkTable :: [Term] -> Term -> Term
mkTable tt t = foldr Table t tt

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

mkHypo :: Term -> Hypo
mkHypo typ = (Explicit,identW, typ)

eqStrIdent :: Ident -> Ident -> Bool
eqStrIdent = (==)

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]

mkCases :: Ident -> Term -> Term
mkCases x t = T TRaw [(PV x, t)]

mkWildCases :: Term -> Term
mkWildCases = mkCases identW

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

--plusRecType :: Type -&gt; Type -&gt; 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 -> raise $ render ("clashing labels" <+> hsep ls)
  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)

--plusRecord :: Term -&gt; Term -&gt; 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
   _ -> raise $ render ("cannot add records" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)

-- | default linearization type
defLinType :: Type
defLinType = RecType [(theLinLabel,  typeStr)]

-- | refreshing variables
mkFreshVar :: [Ident] -> Ident
mkFreshVar olds = varX (maxVarIndex olds + 1)

-- | trying to preserve a given symbol
mkFreshVarX :: [Ident] -> Ident -> Ident
mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x

maxVarIndex :: [Ident] -> Int
maxVarIndex = maximum . ((-1):) . map varIndex

mkFreshVars :: Int -> [Ident] -> [Ident]
mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]

-- | quick hack for refining with var in editor
freshAsTerm :: String -> Term
freshAsTerm s = Vr (varX (readIntArg s))

-- | create a terminal for concrete syntax
string2term :: String -> Term
string2term = K

int2term :: Int -> Term
int2term = EInt

float2term :: Double -> Term
float2term = EFloat

-- | create a terminal from identifier
ident2terminal :: Ident -> Term
ident2terminal = K . showIdent

symbolOfIdent :: Ident -> String
symbolOfIdent = showIdent

symid :: Ident -> String
symid = symbolOfIdent

justIdentOf :: Term -> Maybe Ident
justIdentOf (Vr x) = Just x
justIdentOf (Cn x) = Just x
justIdentOf _ = Nothing

linTypeStr :: Type
linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}

linAsStr :: String -> Term
linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}

-- *** Term and pattern conversion

term2patt :: Term -> Err Patt
term2patt trm = case termForm trm of
  Ok ([], Vr x, []) | x == identW -> return PW
                    | otherwise   -> return (PV x)
  Ok ([], Con c, aa) -> do
    aa' <- mapM term2patt aa
    return (PC c aa')
  Ok ([], QC  c, aa) -> do
    aa' <- mapM term2patt aa
    return (PP c aa')

  Ok ([], Q c, []) -> do
    return (PM c)

  Ok ([], R r, []) -> do
    let (ll,aa) = unzipR r
    aa' <- mapM term2patt aa
    return (PR (zip ll aa'))
  Ok ([],EInt i,[]) -> return $ PInt i
  Ok ([],EFloat i,[]) -> return $ PFloat i
  Ok ([],K s,   []) -> return $ PString s

--- encodings due to excessive use of term-patt convs. AR 7/1/2005
  Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
    b' <- term2patt b
    return (PAs a b')
  Ok ([], Cn id, [a]) | id == cNeg  -> do
    a' <- term2patt a
    return (PNeg a')
  Ok ([], Cn id, [a]) | id == cRep -> do
    a' <- term2patt a
    return (PRep a')
  Ok ([], Cn id, []) | id == cRep -> do
    return PChar
  Ok ([], Cn id,[K s]) | id == cChars  -> do
    return $ PChars s
  Ok ([], Cn id, [a,b]) | id == cSeq -> do
    a' <- term2patt a
    b' <- term2patt b
    return (PSeq a' b')
  Ok ([], Cn id, [a,b]) | id == cAlt -> do
    a' <- term2patt a
    b' <- term2patt b
    return (PAlt a' b')

  Ok ([], Cn c, []) -> do
    return (PMacro c)

  _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)

patt2term :: Patt -> Term
patt2term pt = case pt of
  PV x      -> Vr x
  PW        -> Vr identW             --- not parsable, should not occur
  PMacro c  -> Cn c
  PM c      -> Q c

  PC c pp   -> mkApp (Con c) (map patt2term pp)
  PP c pp   -> mkApp (QC  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   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
  PChar     -> appCons cChar  []                             --- an encoding
  PChars s  -> appCons cChars [K s]                          --- an encoding
  PSeq a b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
  PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
  PRep a    -> appCons cRep   [(patt2term a)]                --- an encoding
  PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding


-- *** Almost compositional

-- | to define compositional term functions
composSafeOp :: (Term -> Term) -> Term -> Term
composSafeOp op = runIdentity . composOp (return . op)

-- | to define compositional term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp co trm =
 case trm of
   App c a          -> liftM2 App (co c) (co a)
   Abs b x t        -> liftM (Abs b x) (co t)
   Prod b x a t     -> liftM2 (Prod b x) (co a) (co t)
   S c a            -> liftM2 S (co c) (co a)
   Table a c        -> liftM2 Table (co a) (co c)
   R r              -> liftM R (mapAssignM co r)
   RecType r        -> liftM RecType (mapPairsM co r)
   P t i            -> liftM2 P (co t) (return i)
   ExtR a c         -> liftM2 ExtR (co a) (co c)
   T i cc           -> liftM2 (flip T) (mapPairsM co cc) (changeTableType co i)
   V ty vs          -> liftM2 V (co ty) (mapM co vs)
   Let (x,(mt,a)) b -> liftM3 let' (co a) (T.mapM co mt) (co b)
     where let' a' mt' b' = Let (x,(mt',a')) b'
   C s1 s2          -> liftM2 C (co s1) (co s2)
   Glue s1 s2       -> liftM2 Glue (co s1) (co s2)
   Alts t aa        -> liftM2 Alts (co t) (mapM (pairM co) aa)
   FV ts            -> liftM FV (mapM co ts)
   Strs tt          -> liftM Strs (mapM co tt)
   EPattType ty     -> liftM EPattType (co ty)
   ELincat c ty     -> liftM (ELincat c) (co ty)
   ELin c ty        -> liftM (ELin c) (co ty)
   ImplArg t        -> liftM ImplArg (co t)
   _ -> return trm -- covers K, Vr, Cn, Sort, EPatt

composSafePattOp op = runIdentity . composPattOp (return . op)

composPattOp :: Monad m => (Patt -> m Patt) -> Patt -> m Patt
composPattOp op patt =
  case patt of
    PC c ps         -> liftM  (PC c) (mapM op ps)
    PP qc ps        -> liftM  (PP qc) (mapM op ps)
    PR as           -> liftM  PR (mapPairsM op as)
    PT ty p         -> liftM  (PT ty) (op p)
    PAs x p         -> liftM  (PAs x) (op p)
    PImplArg p      -> liftM  PImplArg (op p)
    PNeg p          -> liftM  PNeg (op p)
    PAlt p1 p2      -> liftM2 PAlt (op p1) (op p2)
    PSeq p1 p2      -> liftM2 PSeq (op p1) (op p2)
    PMSeq (_,p1) (_,p2) -> liftM2 PSeq (op p1) (op p2) -- information loss
    PRep p          -> liftM  PRep (op p)
    _               -> return patt -- covers cases without subpatterns

collectOp :: Monoid m => (Term -> m) -> Term -> m
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          -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
  RecType r    -> mconcatMap (co . snd) r
  P t i        -> co t
  T _ cc       -> mconcatMap (co . snd) cc -- not from patterns --- nor from type annot
  V _ cc       -> mconcatMap co         cc --- nor from type annot
  Let (x,(mt,a)) b -> maybe mempty 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 <> mconcatMap co (x <> y)
  FV ts        -> mconcatMap co ts
  Strs tt      -> mconcatMap co tt
  _            -> mempty -- covers K, Vr, Cn, Sort

mconcatMap f = mconcat . map f

collectPattOp :: (Patt -> [a]) -> Patt -> [a]
collectPattOp op patt =
  case patt of
    PC c ps         -> concatMap op ps
    PP qc ps        -> concatMap op ps
    PR as           -> concatMap (op.snd) as
    PT ty p         -> op p
    PAs x p         -> op p
    PImplArg p      -> op p
    PNeg p          -> op p
    PAlt p1 p2      -> op p1++op p2
    PSeq p1 p2      -> op p1++op p2
    PMSeq (_,p1) (_,p2) -> op p1++op p2
    PRep p          -> op p
    _               -> []     -- covers cases without subpatterns


-- *** Misc

redirectTerm :: ModuleName -> Term -> Term
redirectTerm n t = case t of
  QC (_,f) -> QC (n,f)
  Q  (_,f) -> Q  (n,f)
  _ -> composSafeOp (redirectTerm n) t

-- | to gather ultimate cases in a table; preserves pattern list
allCaseValues :: Term -> [([Patt],Term)]
allCaseValues trm = case trm of
  T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
  _      -> [([],trm)]

-- | to get a string from a term that represents a sequence of terminals
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case t of
  K s   -> return [str s]
  Empty -> return [str []]
  C s t -> do
    s' <- strsFromTerm s
    t' <- strsFromTerm t
    return [plusStr x y | x <- s', y <- t']
  Glue s t -> do
    s' <- strsFromTerm s
    t' <- strsFromTerm t
    return [glueStr x y | x <- s', y <- t']
  Alts d vs -> do
    d0 <- strsFromTerm d
    v0 <- mapM (strsFromTerm . fst) vs
    c0 <- mapM (strsFromTerm . snd) vs
  --let vs' = zip v0 c0
    return [strTok (str2strings def) vars |
              def  <- d0,
              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
                                                          vv <- sequence v0]
           ]
  FV ts -> mapM strsFromTerm ts >>= return . concat
  Strs ts -> mapM strsFromTerm ts >>= return . concat
  _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))

getTableType :: TInfo -> Err Type
getTableType i = case i of
  TTyped ty -> return ty
  TComp ty  -> return ty
  TWild ty  -> return ty
  _ -> Bad "the table is untyped"

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

-- | to find the word items in a term
wordsInTerm :: Term -> [String]
wordsInTerm trm = filter (not . null) $ case trm of
   K s     -> [s]
   S c _   -> wo c
   Alts t aa -> wo t ++ concatMap (wo . fst) aa
   _       -> collectOp wo trm
 where wo = wordsInTerm

noExist :: Term
noExist = FV []

defaultLinType :: Type
defaultLinType = mkRecType linLabel [typeStr]

-- | normalize records and record types; put s first

sortRec :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where
  ordLabel (r1,_) (r2,_) =
    case (showIdent (label2ident r1), showIdent (label2ident r2)) of
      ("s",_) -> LT
      (_,"s") -> GT
      (s1,s2) -> compare s1 s2

-- *** Dependencies

-- | dependency check, detecting circularities and returning topo-sorted list

allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
allDependencies ism b =
  [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
  where
    opersIn t = case t of
      Q  (n,c) | ism n -> [c]
      QC (n,c) | ism n -> [c]
      _ -> collectOp opersIn t
    opty (Just (L _ ty)) = opersIn ty
    opty _ = []
    pts i = case i of
      ResOper pty pt -> [pty,pt]
      ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
      CncCat pty _ _ _ _ -> [pty]
      CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
      AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
      AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
      _              -> []

topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
topoSortJments (m,mi) = do
  is <- either
          return
          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
          (topoTest (allDependencies (==m) (jments mi)))
  return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])

topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
topoSortJments2 (m,mi) = do
  iss <- either
           return
           (\cyc -> raise (render ("circular definitions:"
                                   <+> fsep (head cyc))))
           (topoTest2 (allDependencies (==m) (jments mi)))
  return
    [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss]