summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Compile/Compute/AppPredefined.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Compile/Compute/AppPredefined.hs')
-rw-r--r--src/compiler/GF/Compile/Compute/AppPredefined.hs143
1 files changed, 0 insertions, 143 deletions
diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs
deleted file mode 100644
index 0869cedee..000000000
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ /dev/null
@@ -1,143 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : AppPredefined
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/06 14:21:34 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.13 $
---
--- Predefined function type signatures and definitions.
------------------------------------------------------------------------------
-
-module GF.Compile.Compute.AppPredefined ({-
- isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined-}
- ) where
-{-
-import GF.Compile.TypeCheck.Primitives
-import GF.Infra.Option
-import GF.Data.Operations
-import GF.Grammar
-import GF.Grammar.Predef
-
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import Data.Char (isUpper,toUpper,toLower)
-
--- predefined function type signatures and definitions. AR 12/3/2003.
-
-isInPredefined :: Ident -> Bool
-isInPredefined f = Map.member f primitives
-
-arrityPredefined :: Ident -> Maybe Int
-arrityPredefined f = do ty <- typPredefined f
- let (ctxt,_) = typeFormCnc ty
- return (length ctxt)
-
-predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
-
-appPredefined :: Term -> Err (Term,Bool)
-appPredefined t = case t of
- App f x0 -> do
- (x,_) <- appPredefined x0
- case f of
- -- one-place functions
- Q (mod,f) | mod == cPredef ->
- case x of
- (K s) | f == cLength -> retb $ EInt $ length s
- (K s) | f == cIsUpper -> retb $ if (all isUpper s) then predefTrue else predefFalse
- (K s) | f == cToUpper -> retb $ K $ map toUpper s
- (K s) | f == cToLower -> retb $ K $ map toLower s
- (K s) | f == cError -> retb $ Error s
-
- _ -> retb t
-
- -- two-place functions
- App (Q (mod,f)) z0 | mod == cPredef -> do
- (z,_) <- appPredefined z0
- case (norm z, norm x) of
- (EInt i, K s) | f == cDrop -> retb $ K (drop i s)
- (EInt i, K s) | f == cTake -> retb $ K (take i s)
- (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - i)) s)
- (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - i)) s)
- (K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse
- (K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse
- (K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse
- (EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse
- (EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
- (EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
- (_, t) | f == cShow && notVar t -> retb $ foldrC $ map K $ words $ render (ppTerm Unqualified 0 t)
- (_, K s) | f == cRead -> retb $ Cn (identS s) --- because of K, only works for atomic tags
- (_, t) | f == cToStr -> trm2str t >>= retb
- _ -> retb t ---- prtBad "cannot compute predefined" t
-
- -- three-place functions
- App (App (Q (mod,f)) z0) y0 | mod == cPredef -> do
- (y,_) <- appPredefined y0
- (z,_) <- appPredefined z0
- case (z, y, x) of
- (ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
- _ | f == cEqVal && notVar y && notVar x -> retb $ if y==x then predefTrue else predefFalse
- _ -> retb t ---- prtBad "cannot compute predefined" t
-
- _ -> retb t ---- prtBad "cannot compute predefined" t
- _ -> retb t
- ---- should really check the absence of arg variables
- where
- retb t = return (retc t,True) -- no further computing needed
- retf t = return (retc t,False) -- must be computed further
- retc t = case t of
- K [] -> t
- K s -> foldr1 C (map K (words s))
- _ -> t
- norm t = case t of
- Empty -> K []
- C u v -> case (norm u,norm v) of
- (K x,K y) -> K (x +++ y)
- _ -> t
- _ -> t
- notVar t = case t of
- Vr _ -> False
- App f a -> notVar f && notVar a
- _ -> True ---- would need to check that t is a value
- foldrC ts = if null ts then Empty else foldr1 C ts
-
--- read makes variables into constants
-
-predefTrue = QC (cPredef,cPTrue)
-predefFalse = QC (cPredef,cPFalse)
-
-substring :: String -> String -> Bool
-substring s t = case (s,t) of
- (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
- ([],_) -> True
- _ -> False
-
-trm2str :: Term -> Err Term
-trm2str t = case t of
- R ((_,(_,s)):_) -> trm2str s
- T _ ((_,s):_) -> trm2str s
- V _ (s:_) -> trm2str s
- C _ _ -> return $ t
- K _ -> return $ t
- S c _ -> trm2str c
- Empty -> return $ t
- _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-
--- simultaneous recursion on type and term: type arg is essential!
--- But simplify the task by assuming records are type-annotated
--- (this has been done in type checking)
-mapStr :: Type -> Term -> Term -> Term
-mapStr ty f t = case (ty,t) of
- _ | elem ty [typeStr,typeTok] -> App f t
- (_, R ts) -> R [(l,mapField v) | (l,v) <- ts]
- (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
- _ -> t
- where
- mapField (mty,te) = case mty of
- Just ty -> (mty,mapStr ty f te)
- _ -> (mty,te)
--}