summaryrefslogtreecommitdiff
path: root/src/GF/Grammar/AppPredefined.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
commitb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch)
tree0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/Grammar/AppPredefined.hs
parentfe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff)
removed src for 2.9
Diffstat (limited to 'src/GF/Grammar/AppPredefined.hs')
-rw-r--r--src/GF/Grammar/AppPredefined.hs159
1 files changed, 0 insertions, 159 deletions
diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs
deleted file mode 100644
index 530184c3e..000000000
--- a/src/GF/Grammar/AppPredefined.hs
+++ /dev/null
@@ -1,159 +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.Grammar.AppPredefined (isInPredefined, typPredefined, appPredefined
- ) where
-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Macros
-import GF.Grammar.PrGrammar (prt,prt_,prtBad)
----- import PGrammar (pTrm)
-
--- predefined function type signatures and definitions. AR 12/3/2003.
-
-isInPredefined :: Ident -> Bool
-isInPredefined = err (const True) (const False) . typPredefined
-
-typPredefined :: Ident -> Err Type
-typPredefined c@(IC f) = case f of
- "Int" -> return typePType
- "Float" -> return typeType
- "Error" -> return typeType
- "Ints" -> return $ mkFunType [cnPredef "Int"] typePType
- "PBool" -> return typePType
- "error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set
- "PFalse" -> return $ cnPredef "PBool"
- "PTrue" -> return $ cnPredef "PBool"
- "dp" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
- "drop" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
- "eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
- "lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
- "eqStr" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
- "length" -> return $ mkFunType [typeTok] (cnPredef "Int")
- "occur" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
- "occurs" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
- "plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
----- "read" -> (P : Type) -> Tok -> P
- "show" -> return $ mkProd -- (P : PType) -> P -> Tok
- ([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[])
- "toStr" -> return $ mkProd -- (L : Type) -> L -> Str
- ([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[])
- "mapStr" ->
- let ty = zIdent "L" in
- return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
- ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[])
- "take" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
- "tk" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
- _ -> prtBad "unknown in Predef:" c
-typPredefined c = prtBad "unknown in Predef:" c
-
-appPredefined :: Term -> Err (Term,Bool)
-appPredefined t = case t of
-
- App f x0 -> do
- (x,_) <- appPredefined x0
- case f of
- -- one-place functions
- Q (IC "Predef") (IC f) -> case (f, x) of
- ("length", K s) -> retb $ EInt $ toInteger $ length s
- _ -> retb t ---- prtBad "cannot compute predefined" t
-
- -- two-place functions
- App (Q (IC "Predef") (IC f)) z0 -> do
- (z,_) <- appPredefined z0
- case (f, norm z, norm x) of
- ("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
- ("take", EInt i, K s) -> retb $ K (take (fi i) s)
- ("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
- ("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
- ("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse
- ("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse
- ("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
- ("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
- ("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
- ("plus", EInt i, EInt j) -> retb $ EInt $ i+j
- ("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
- ("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
- ("toStr", _, t) -> trm2str t >>= retb
-
- _ -> retb t ---- prtBad "cannot compute predefined" t
-
- -- three-place functions
- App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
- (y,_) <- appPredefined y0
- (z,_) <- appPredefined z0
- case (f, z, y, x) of
- ("mapStr",ty,op,t) -> retf $ mapStr ty op t
- _ -> 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 (t,True) -- no further computing needed
- retf t = return (t,False) -- must be computed further
- norm t = case t of
- Empty -> K []
- _ -> t
- fi = fromInteger
-
--- read makes variables into constants
-
-str2tag :: String -> Term
-str2tag s = case s of
----- '\'' : cs -> mkCn $ pTrm $ init cs
- _ -> Cn $ IC s ---
- where
- mkCn t = case t of
- Vr i -> Cn i
- App c a -> App (mkCn c) (mkCn a)
- _ -> t
-
-
-predefTrue = Q (IC "Predef") (IC "PTrue")
-predefFalse = Q (IC "Predef") (IC "PFalse")
-
-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
- TSh _ ((_,s):_) -> trm2str s
- V _ (s:_) -> trm2str s
- C _ _ -> return $ t
- K _ -> return $ t
- S c _ -> trm2str c
- Empty -> return $ t
- _ -> prtBad "cannot get Str from term" 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)