mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-15 22:22:51 -06:00
changed names of resource-1.3; added a note on homepage on release
This commit is contained in:
aarne
75
src/GF/Grammar/API.hs
Normal file
75
src/GF/Grammar/API.hs
Normal file
@@ -0,0 +1,75 @@
|
||||
module GF.Grammar.API (
|
||||
Grammar,
|
||||
emptyGrammar,
|
||||
pTerm,
|
||||
prTerm,
|
||||
checkTerm,
|
||||
computeTerm,
|
||||
showTerm,
|
||||
TermPrintStyle(..),
|
||||
pTermPrintStyle
|
||||
) where
|
||||
|
||||
import GF.Source.ParGF
|
||||
import GF.Source.SourceToGrammar (transExp)
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules (greatestResource)
|
||||
import GF.Compile.GetGrammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
import GF.Compile.Rename (renameSourceTerm)
|
||||
import GF.Compile.CheckGrammar (justCheckLTerm)
|
||||
import GF.Compile.Compute (computeConcrete)
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.Option
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
type Grammar = SourceGrammar
|
||||
|
||||
emptyGrammar :: Grammar
|
||||
emptyGrammar = emptySourceGrammar
|
||||
|
||||
pTerm :: String -> Err Term
|
||||
pTerm s = do
|
||||
e <- pExp $ myLexer (BS.pack s)
|
||||
transExp e
|
||||
|
||||
prTerm :: Term -> String
|
||||
prTerm = prt
|
||||
|
||||
checkTerm :: Grammar -> Term -> Err Term
|
||||
checkTerm gr t = do
|
||||
mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr
|
||||
checkTermAny gr mo t
|
||||
|
||||
checkTermAny :: Grammar -> Ident -> Term -> Err Term
|
||||
checkTermAny gr m t = do
|
||||
t1 <- renameSourceTerm gr m t
|
||||
justCheckLTerm gr t1
|
||||
|
||||
computeTerm :: Grammar -> Term -> Err Term
|
||||
computeTerm = computeConcrete
|
||||
|
||||
showTerm :: TermPrintStyle -> Term -> String
|
||||
showTerm style t =
|
||||
case style of
|
||||
TermPrintTable -> unlines [p +++ s | (p,s) <- prTermTabular t]
|
||||
TermPrintAll -> unlines [ s | (p,s) <- prTermTabular t]
|
||||
TermPrintUnqual -> prt_ t
|
||||
TermPrintDefault -> prt t
|
||||
|
||||
|
||||
data TermPrintStyle = TermPrintTable | TermPrintAll | TermPrintUnqual | TermPrintDefault
|
||||
deriving (Show,Eq)
|
||||
|
||||
pTermPrintStyle s = case s of
|
||||
"table" -> TermPrintTable
|
||||
"all" -> TermPrintAll
|
||||
"unqual" -> TermPrintUnqual
|
||||
_ -> TermPrintDefault
|
||||
|
||||
|
||||
38
src/GF/Grammar/Abstract.hs
Normal file
38
src/GF/Grammar/Abstract.hs
Normal file
@@ -0,0 +1,38 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Abstract
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:18 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Abstract (
|
||||
|
||||
module GF.Grammar.Grammar,
|
||||
module GF.Grammar.Values,
|
||||
module GF.Grammar.Macros,
|
||||
module GF.Infra.Ident,
|
||||
module GF.Grammar.MMacros,
|
||||
module GF.Grammar.PrGrammar,
|
||||
|
||||
Grammar
|
||||
|
||||
) where
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Macros
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.MMacros
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
type Grammar = SourceGrammar ---
|
||||
|
||||
|
||||
|
||||
158
src/GF/Grammar/AppPredefined.hs
Normal file
158
src/GF/Grammar/AppPredefined.hs
Normal file
@@ -0,0 +1,158 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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.Infra.Ident
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar (prt,prt_,prtBad)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
-- 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 f
|
||||
| f == cInt = return typePType
|
||||
| f == cFloat = return typePType
|
||||
| f == cErrorType = return typeType
|
||||
| f == cInts = return $ mkFunType [typeInt] typePType
|
||||
| f == cPBool = return typePType
|
||||
| f == cError = return $ mkFunType [typeStr] typeError -- non-can. of empty set
|
||||
| f == cPFalse = return $ typePBool
|
||||
| f == cPTrue = return $ typePBool
|
||||
| f == cDp = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| f == cDrop = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| f == cEqInt = return $ mkFunType [typeInt,typeInt] typePBool
|
||||
| f == cLessInt = return $ mkFunType [typeInt,typeInt] typePBool
|
||||
| f == cEqStr = return $ mkFunType [typeTok,typeTok] typePBool
|
||||
| f == cLength = return $ mkFunType [typeTok] typeInt
|
||||
| f == cOccur = return $ mkFunType [typeTok,typeTok] typePBool
|
||||
| f == cOccurs = return $ mkFunType [typeTok,typeTok] typePBool
|
||||
| f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt)
|
||||
---- "read" -> (P : Type) -> Tok -> P
|
||||
| f == cShow = return $ mkProd -- (P : PType) -> P -> Tok
|
||||
([(varP,typePType),(identW,Vr varP)],typeStr,[])
|
||||
| f == cToStr = return $ mkProd -- (L : Type) -> L -> Str
|
||||
([(varL,typeType),(identW,Vr varL)],typeStr,[])
|
||||
| f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
|
||||
([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
|
||||
| f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
|
||||
| otherwise = prtBad "unknown in Predef:" f
|
||||
|
||||
varL :: Ident
|
||||
varL = identC (BS.pack "L")
|
||||
|
||||
varP :: Ident
|
||||
varP = identC (BS.pack "P")
|
||||
|
||||
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 $ toInteger $ length 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 (fi i) s)
|
||||
(EInt i, K s) | f == cTake -> retb $ K (take (fi i) s)
|
||||
(EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s)
|
||||
(EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi 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 -> retb $ foldr C Empty $ map K $ words $ prt t
|
||||
(_, K s) | f == cRead -> retb $ Cn (identC (BS.pack 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
|
||||
_ -> 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
|
||||
fi = fromInteger
|
||||
|
||||
-- read makes variables into constants
|
||||
|
||||
predefTrue = Q cPredef cPTrue
|
||||
predefFalse = Q 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
|
||||
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)
|
||||
264
src/GF/Grammar/Grammar.hs
Normal file
264
src/GF/Grammar/Grammar.hs
Normal file
@@ -0,0 +1,264 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Grammar
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:20 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- GF source abstract syntax used internally in compilation.
|
||||
--
|
||||
-- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Grammar (SourceGrammar,
|
||||
emptySourceGrammar,
|
||||
SourceModInfo,
|
||||
SourceModule,
|
||||
SourceAbs,
|
||||
SourceRes,
|
||||
SourceCnc,
|
||||
Info(..),
|
||||
PValues,
|
||||
Perh,
|
||||
MPr,
|
||||
Type,
|
||||
Cat,
|
||||
Fun,
|
||||
QIdent,
|
||||
Term(..),
|
||||
Patt(..),
|
||||
TInfo(..),
|
||||
Label(..),
|
||||
MetaSymb(..),
|
||||
Decl,
|
||||
Context,
|
||||
Equation,
|
||||
Labelling,
|
||||
Assign,
|
||||
Case,
|
||||
Cases,
|
||||
LocalDef,
|
||||
Param,
|
||||
Altern,
|
||||
Substitution,
|
||||
Branch(..),
|
||||
Con,
|
||||
Trm,
|
||||
wildPatt,
|
||||
varLabel, tupleLabel, linLabel, theLinLabel,
|
||||
ident2label, label2ident
|
||||
) where
|
||||
|
||||
import GF.Data.Str
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option ---
|
||||
import GF.Infra.Modules
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
-- | grammar as presented to the compiler
|
||||
type SourceGrammar = MGrammar Ident Info
|
||||
|
||||
emptySourceGrammar = MGrammar []
|
||||
|
||||
type SourceModInfo = ModInfo Ident Info
|
||||
|
||||
type SourceModule = (Ident, SourceModInfo)
|
||||
|
||||
type SourceAbs = Module Ident Info
|
||||
type SourceRes = Module Ident Info
|
||||
type SourceCnc = Module Ident Info
|
||||
|
||||
-- this is created in CheckGrammar, and so are Val and PVal
|
||||
type PValues = [Term]
|
||||
|
||||
-- | the constructors are judgements in
|
||||
--
|
||||
-- - abstract syntax (/ABS/)
|
||||
--
|
||||
-- - resource (/RES/)
|
||||
--
|
||||
-- - concrete syntax (/CNC/)
|
||||
--
|
||||
-- and indirection to module (/INDIR/)
|
||||
data Info =
|
||||
-- judgements in abstract syntax
|
||||
AbsCat (Perh Context) (Perh [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
|
||||
| AbsFun (Perh Type) (Perh Term) -- ^ (/ABS/) 'Yes f' = canonical
|
||||
| AbsTrans Term -- ^ (/ABS/)
|
||||
|
||||
-- judgements in resource
|
||||
| ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)
|
||||
| ResValue (Perh (Type,Maybe Int)) -- ^ (/RES/) to mark parameter constructors for lookup
|
||||
| ResOper (Perh Type) (Perh Term) -- ^ (/RES/)
|
||||
|
||||
| ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited
|
||||
|
||||
-- judgements in concrete syntax
|
||||
| CncCat (Perh Type) (Perh Term) MPr -- ^ (/CNC/) lindef ini'zed,
|
||||
| CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- (/CNC/) type info added at 'TC'
|
||||
|
||||
-- indirection to module Ident
|
||||
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
|
||||
deriving (Read, Show)
|
||||
|
||||
-- | to express indirection to other module
|
||||
type Perh a = Perhaps a Ident
|
||||
|
||||
-- | printname
|
||||
type MPr = Perhaps Term Ident
|
||||
|
||||
type Type = Term
|
||||
type Cat = QIdent
|
||||
type Fun = QIdent
|
||||
|
||||
type QIdent = (Ident,Ident)
|
||||
|
||||
data Term =
|
||||
Vr Ident -- ^ variable
|
||||
| Cn Ident -- ^ constant
|
||||
| Con Ident -- ^ constructor
|
||||
| EData -- ^ to mark in definition that a fun is a constructor
|
||||
| Sort Ident -- ^ basic type
|
||||
| EInt Integer -- ^ integer literal
|
||||
| EFloat Double -- ^ floating point literal
|
||||
| K String -- ^ string literal or token: @\"foo\"@
|
||||
| Empty -- ^ the empty string @[]@
|
||||
|
||||
| App Term Term -- ^ application: @f a@
|
||||
| Abs Ident Term -- ^ abstraction: @\x -> b@
|
||||
| Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0)
|
||||
| Prod Ident Term Term -- ^ function type: @(x : A) -> B@
|
||||
| Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@
|
||||
-- only used in internal representation
|
||||
| Typed Term Term -- ^ type-annotated term
|
||||
--
|
||||
-- /below this, the constructors are only for concrete syntax/
|
||||
| Example Term String -- ^ example-based term: @in M.C "foo"
|
||||
| RecType [Labelling] -- ^ record type: @{ p : A ; ...}@
|
||||
| R [Assign] -- ^ record: @{ p = a ; ...}@
|
||||
| P Term Label -- ^ projection: @r.p@
|
||||
| PI Term Label Int -- ^ index-annotated projection
|
||||
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
|
||||
|
||||
| Table Term Term -- ^ table type: @P => A@
|
||||
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@
|
||||
| TSh TInfo [Cases] -- ^ table with disjunctive patters (only back end opt)
|
||||
| V Type [Term] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
|
||||
| S Term Term -- ^ selection: @t ! p@
|
||||
| Val Type Int -- ^ parameter value number: @T # i#
|
||||
|
||||
| Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
|
||||
|
||||
| Alias Ident Type Term -- ^ constant and its definition, used in inlining
|
||||
|
||||
| Q Ident Ident -- ^ qualified constant from a package
|
||||
| QC Ident Ident -- ^ qualified constructor from a package
|
||||
|
||||
| C Term Term -- ^ concatenation: @s ++ t@
|
||||
| Glue Term Term -- ^ agglutination: @s + t@
|
||||
|
||||
| EPatt Patt -- ^ pattern (in macro definition): # p
|
||||
| EPattType Term -- ^ pattern type: pattern T
|
||||
|
||||
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
|
||||
|
||||
| Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
|
||||
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
|
||||
--
|
||||
-- /below this, the last three constructors are obsolete/
|
||||
| LiT Ident -- ^ linearization type
|
||||
| Ready Str -- ^ result of compiling; not to be parsed ...
|
||||
| Computed Term -- ^ result of computing: not to be reopened nor parsed
|
||||
|
||||
deriving (Read, Show, Eq, Ord)
|
||||
|
||||
data Patt =
|
||||
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@
|
||||
| PP Ident Ident [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@
|
||||
| PV Ident -- ^ variable pattern: @x@
|
||||
| PW -- ^ wild card pattern: @_@
|
||||
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
|
||||
| PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
|
||||
| PInt Integer -- ^ integer literal pattern: @12@ -- only abstract
|
||||
| PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract
|
||||
| PT Type Patt -- ^ type-annotated pattern
|
||||
|
||||
| PVal Type Int -- ^ parameter value number: @T # i#
|
||||
|
||||
| PAs Ident Patt -- ^ as-pattern: x@p
|
||||
|
||||
-- regular expression patterns
|
||||
| PNeg Patt -- ^ negated pattern: -p
|
||||
| PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2
|
||||
| PSeq Patt Patt -- ^ sequence of token parts: p + q
|
||||
| PRep Patt -- ^ repetition of token part: p*
|
||||
| PChar -- ^ string of length one: ?
|
||||
| PChars [Char] -- ^ character list: ["aeiou"]
|
||||
| PMacro Ident -- #p
|
||||
| PM Ident Ident -- #m.p
|
||||
|
||||
deriving (Read, Show, Eq, Ord)
|
||||
|
||||
-- | to guide computation and type checking of tables
|
||||
data TInfo =
|
||||
TRaw -- ^ received from parser; can be anything
|
||||
| TTyped Type -- ^ type annontated, but can be anything
|
||||
| TComp Type -- ^ expanded
|
||||
| TWild Type -- ^ just one wild card pattern, no need to expand
|
||||
deriving (Read, Show, Eq, Ord)
|
||||
|
||||
-- | record label
|
||||
data Label =
|
||||
LIdent BS.ByteString
|
||||
| LVar Int
|
||||
deriving (Read, Show, Eq, Ord)
|
||||
|
||||
newtype MetaSymb = MetaSymb Int deriving (Read, Show, Eq, Ord)
|
||||
|
||||
type Decl = (Ident,Term) -- (x:A) (_:A) A
|
||||
type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A)
|
||||
type Equation = ([Patt],Term)
|
||||
|
||||
type Labelling = (Label, Term)
|
||||
type Assign = (Label, (Maybe Type, Term))
|
||||
type Case = (Patt, Term)
|
||||
type Cases = ([Patt], Term)
|
||||
type LocalDef = (Ident, (Maybe Type, Term))
|
||||
|
||||
type Param = (Ident, Context)
|
||||
type Altern = (Term, [(Term, Term)])
|
||||
|
||||
type Substitution = [(Ident, Term)]
|
||||
|
||||
-- | branches à la Alfa
|
||||
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
|
||||
type Con = Ident ---
|
||||
|
||||
varLabel :: Int -> Label
|
||||
varLabel = LVar
|
||||
|
||||
tupleLabel, linLabel :: Int -> Label
|
||||
tupleLabel i = LIdent $! BS.pack ('p':show i)
|
||||
linLabel i = LIdent $! BS.pack ('s':show i)
|
||||
|
||||
theLinLabel :: Label
|
||||
theLinLabel = LIdent (BS.singleton 's')
|
||||
|
||||
ident2label :: Ident -> Label
|
||||
ident2label c = LIdent (ident2bs c)
|
||||
|
||||
label2ident :: Label -> Ident
|
||||
label2ident (LIdent s) = identC s
|
||||
label2ident (LVar i) = identC (BS.pack ('$':show i))
|
||||
|
||||
wildPatt :: Patt
|
||||
wildPatt = PV identW
|
||||
|
||||
type Trm = Term
|
||||
51
src/GF/Grammar/Lockfield.hs
Normal file
51
src/GF/Grammar/Lockfield.hs
Normal file
@@ -0,0 +1,51 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Lockfield
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 23:24:34 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- Creating and using lock fields in reused resource grammars.
|
||||
--
|
||||
-- AR 8\/2\/2005 detached from 'compile/MkResource'
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
lockRecType :: Ident -> Type -> Err Type
|
||||
lockRecType c t@(RecType rs) =
|
||||
let lab = lockLabel c in
|
||||
return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"]
|
||||
then t --- don't add an extra copy of lock field, nor predef cats
|
||||
else RecType (rs ++ [(lockLabel c, RecType [])])
|
||||
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]
|
||||
|
||||
unlockRecord :: Ident -> Term -> Err Term
|
||||
unlockRecord c ft = do
|
||||
let (xs,t) = termFormCnc ft
|
||||
t' <- plusRecord t $ R [(lockLabel c, (Just (RecType []),R []))]
|
||||
return $ mkAbs xs t'
|
||||
|
||||
lockLabel :: Ident -> Label
|
||||
lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c)
|
||||
|
||||
isLockLabel :: Label -> Bool
|
||||
isLockLabel l = case l of
|
||||
LIdent c -> BS.isPrefixOf lockPrefix c
|
||||
_ -> False
|
||||
|
||||
|
||||
lockPrefix = BS.pack "lock_"
|
||||
53
src/GF/Grammar/LookAbs.hs
Normal file
53
src/GF/Grammar/LookAbs.hs
Normal file
@@ -0,0 +1,53 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : LookAbs
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/28 16:42:48 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.14 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.LookAbs (
|
||||
lookupFunType,
|
||||
lookupCatContext
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Infra.Modules
|
||||
|
||||
import Data.List (nub)
|
||||
import Control.Monad
|
||||
|
||||
-- | this is needed at compile time
|
||||
lookupFunType :: Grammar -> Ident -> Ident -> Err Type
|
||||
lookupFunType gr m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
AbsFun (Yes t) _ -> return t
|
||||
AnyInd _ n -> lookupFunType gr n c
|
||||
_ -> prtBad "cannot find type of" c
|
||||
_ -> Bad $ prt m +++ "is not an abstract module"
|
||||
|
||||
-- | this is needed at compile time
|
||||
lookupCatContext :: Grammar -> Ident -> Ident -> Err Context
|
||||
lookupCatContext gr m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
AbsCat (Yes co) _ -> return co
|
||||
AnyInd _ n -> lookupCatContext gr n c
|
||||
_ -> prtBad "unknown category" c
|
||||
_ -> Bad $ prt m +++ "is not an abstract module"
|
||||
269
src/GF/Grammar/Lookup.hs
Normal file
269
src/GF/Grammar/Lookup.hs
Normal file
@@ -0,0 +1,269 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Lookup
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/27 13:21:53 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.15 $
|
||||
--
|
||||
-- Lookup in source (concrete and resource) when compiling.
|
||||
--
|
||||
-- lookup in resource and concrete in compiling; for abstract, use 'Look'
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Lookup (
|
||||
lookupResDef,
|
||||
lookupResDefKind,
|
||||
lookupResType,
|
||||
lookupOverload,
|
||||
lookupParams,
|
||||
lookupParamValues,
|
||||
lookupFirstTag,
|
||||
lookupValueIndex,
|
||||
lookupIndexValue,
|
||||
allOrigInfos,
|
||||
allParamValues,
|
||||
lookupAbsDef,
|
||||
lookupLincat,
|
||||
opersForType
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Infra.Modules
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Lockfield
|
||||
|
||||
import Data.List (nub,sortBy)
|
||||
import Control.Monad
|
||||
|
||||
-- whether lock fields are added in reuse
|
||||
lock c = lockRecType c -- return
|
||||
unlock c = unlockRecord c -- return
|
||||
|
||||
lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
|
||||
lookupResDef gr m c = liftM fst $ lookupResDefKind gr m c
|
||||
|
||||
-- 0 = oper, 1 = lin, 2 = canonical. v > 0 means: no need to be recomputed
|
||||
lookupResDefKind :: SourceGrammar -> Ident -> Ident -> Err (Term,Int)
|
||||
lookupResDefKind gr m c
|
||||
| isPredefCat c = return (Q cPredefAbs c,2) --- need this in gf3 12/6/2008
|
||||
| otherwise = look True m c where
|
||||
look isTop m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfoIn mo m c
|
||||
case info of
|
||||
ResOper _ (Yes t) -> return (qualifAnnot m t, 0)
|
||||
ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c
|
||||
---- else prtBad "cannot find in exts" c
|
||||
|
||||
CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty
|
||||
CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType
|
||||
CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr
|
||||
|
||||
CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
|
||||
|
||||
AnyInd _ n -> look False n c
|
||||
ResParam _ -> return (QC m c,2)
|
||||
ResValue _ -> return (QC m c,2)
|
||||
_ -> Bad $ prt c +++ "is not defined in resource" +++ prt m
|
||||
_ -> Bad $ prt m +++ "is not a resource"
|
||||
lookExt m c =
|
||||
checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])
|
||||
|
||||
lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
|
||||
lookupResType gr m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
ResOper (Yes t) _ -> return $ qualifAnnot m t
|
||||
ResOper (May n) _ -> lookupResType gr n c
|
||||
|
||||
-- used in reused concrete
|
||||
CncCat _ _ _ -> return typeType
|
||||
CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
|
||||
val' <- lock cat val
|
||||
return $ mkProd (cont, val', [])
|
||||
CncFun _ _ _ -> lookFunType m m c
|
||||
AnyInd _ n -> lookupResType gr n c
|
||||
ResParam _ -> return $ typePType
|
||||
ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t
|
||||
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
|
||||
_ -> Bad $ prt m +++ "is not a resource"
|
||||
where
|
||||
lookFunType e m c = do
|
||||
a <- abstractOfConcrete gr m
|
||||
lookFun e m c a
|
||||
lookFun e m c a = do
|
||||
mu <- lookupModMod gr a
|
||||
info <- lookupIdentInfo mu c
|
||||
case info of
|
||||
AbsFun (Yes ty) _ -> return $ redirectTerm e ty
|
||||
AbsCat _ _ -> return typeType
|
||||
AnyInd _ n -> lookFun e m c n
|
||||
_ -> prtBad "cannot find type of reused function" c
|
||||
|
||||
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
|
||||
lookupOverload gr m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
ResOverload os tysts -> do
|
||||
tss <- mapM (\x -> lookupOverload gr x c) os
|
||||
return $ [(map snd args,(val,tr)) |
|
||||
(ty,tr) <- tysts, Ok (args,val) <- [typeFormCnc ty]] ++
|
||||
concat tss
|
||||
|
||||
AnyInd _ n -> lookupOverload gr n c
|
||||
_ -> Bad $ prt c +++ "is not an overloaded operation"
|
||||
_ -> Bad $ prt m +++ "is not a resource"
|
||||
|
||||
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info
|
||||
lookupOrigInfo gr m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
AnyInd _ n -> lookupOrigInfo gr n c
|
||||
i -> return i
|
||||
_ -> Bad $ prt m +++ "is not run-time module"
|
||||
|
||||
lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues)
|
||||
lookupParams gr = look True where
|
||||
look isTop m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
ResParam (Yes psm) -> return psm
|
||||
AnyInd _ n -> look False n c
|
||||
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
|
||||
_ -> Bad $ prt m +++ "is not a resource"
|
||||
lookExt m c =
|
||||
checks [look False n c | n <- allExtensions gr m]
|
||||
|
||||
lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
|
||||
lookupParamValues gr m c = do
|
||||
(ps,mpv) <- lookupParams gr m c
|
||||
case mpv of
|
||||
Just ts -> return ts
|
||||
_ -> liftM concat $ mapM mkPar ps
|
||||
where
|
||||
mkPar (f,co) = do
|
||||
vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co
|
||||
return $ map (mkApp (QC m f)) vs
|
||||
|
||||
lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term
|
||||
lookupFirstTag gr m c = do
|
||||
vs <- lookupParamValues gr m c
|
||||
case vs of
|
||||
v:_ -> return v
|
||||
_ -> prtBad "no parameter values given to type" c
|
||||
|
||||
lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
|
||||
lookupValueIndex gr ty tr = do
|
||||
ts <- allParamValues gr ty
|
||||
case lookup tr $ zip ts [0..] of
|
||||
Just i -> return $ Val ty i
|
||||
_ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty
|
||||
|
||||
lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
|
||||
lookupIndexValue gr ty i = do
|
||||
ts <- allParamValues gr ty
|
||||
if i < length ts
|
||||
then return $ ts !! i
|
||||
else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty
|
||||
|
||||
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
|
||||
allOrigInfos gr m = errVal [] $ do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]]
|
||||
where
|
||||
look = lookupOrigInfo gr m
|
||||
|
||||
allParamValues :: SourceGrammar -> Type -> Err [Term]
|
||||
allParamValues cnc ptyp = case ptyp of
|
||||
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
|
||||
QC p c -> lookupParamValues cnc p c
|
||||
Q p c -> lookupResDef cnc p c >>= allParamValues cnc
|
||||
RecType r -> do
|
||||
let (ls,tys) = unzip $ sortByFst r
|
||||
tss <- mapM allPV tys
|
||||
return [R (zipAssign ls ts) | ts <- combinations tss]
|
||||
_ -> prtBad "cannot find parameter values for" ptyp
|
||||
where
|
||||
allPV = allParamValues cnc
|
||||
-- to normalize records and record types
|
||||
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
|
||||
|
||||
qualifAnnot :: Ident -> Term -> Term
|
||||
qualifAnnot _ = id
|
||||
-- Using this we wouldn't have to annotate constants defined in a module itself.
|
||||
-- But things are simpler if we do (cf. Zinc).
|
||||
-- Change Rename.self2status to change this behaviour.
|
||||
|
||||
-- we need this for lookup in ResVal
|
||||
qualifAnnotPar m t = case t of
|
||||
Cn c -> Q m c
|
||||
Con c -> QC m c
|
||||
_ -> composSafeOp (qualifAnnotPar m) t
|
||||
|
||||
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Term)
|
||||
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
AbsFun _ (Yes t) -> return $ return t
|
||||
AnyInd _ n -> lookupAbsDef gr n c
|
||||
_ -> return Nothing
|
||||
_ -> Bad $ prt m +++ "is not an abstract module"
|
||||
|
||||
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
|
||||
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
|
||||
lookupLincat gr m c = do
|
||||
mi <- lookupModule gr m
|
||||
case mi of
|
||||
ModMod mo -> do
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
CncCat (Yes t) _ _ -> return t
|
||||
AnyInd _ n -> lookupLincat gr n c
|
||||
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m
|
||||
_ -> Bad $ prt m +++ "is not concrete"
|
||||
|
||||
|
||||
-- The first type argument is uncomputed, usually a category symbol.
|
||||
-- This is a hack to find implicit (= reused) opers.
|
||||
|
||||
opersForType :: SourceGrammar -> Type -> Type -> [(QIdent,Term)]
|
||||
opersForType gr orig val =
|
||||
[((i,f),ty) | (i,m) <- allModMod gr, (f,ty) <- opers i m val] where
|
||||
opers i m val =
|
||||
[(f,ty) |
|
||||
(f,ResOper (Yes ty) _) <- tree2list $ jments m,
|
||||
Ok valt <- [valTypeCnc ty],
|
||||
elem valt [val,orig]
|
||||
] ++
|
||||
let cat = err error snd (valCat orig) in --- ignore module
|
||||
[(f,ty) |
|
||||
Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr],
|
||||
(f, AbsFun (Yes ty0) _) <- tree2list $ jments a,
|
||||
let ty = redirectTerm i ty0,
|
||||
Ok valt <- [valCat ty],
|
||||
cat == snd valt ---
|
||||
]
|
||||
339
src/GF/Grammar/MMacros.hs
Normal file
339
src/GF/Grammar/MMacros.hs
Normal file
@@ -0,0 +1,339 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : MMacros
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/10 12:49:13 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.9 $
|
||||
--
|
||||
-- some more abstractions on grammars, esp. for Edit
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.MMacros where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Zipper
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Compile.Refresh
|
||||
import GF.Grammar.Values
|
||||
----import GrammarST
|
||||
import GF.Grammar.Macros
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
nodeTree :: Tree -> TrNode
|
||||
argsTree :: Tree -> [Tree]
|
||||
|
||||
nodeTree (Tr (n,_)) = n
|
||||
argsTree (Tr (_,ts)) = ts
|
||||
|
||||
isFocusNode :: TrNode -> Bool
|
||||
bindsNode :: TrNode -> Binds
|
||||
atomNode :: TrNode -> Atom
|
||||
valNode :: TrNode -> Val
|
||||
constrsNode :: TrNode -> Constraints
|
||||
metaSubstsNode :: TrNode -> MetaSubst
|
||||
|
||||
isFocusNode (N (_,_,_,_,b)) = b
|
||||
bindsNode (N (b,_,_,_,_)) = b
|
||||
atomNode (N (_,a,_,_,_)) = a
|
||||
valNode (N (_,_,v,_,_)) = v
|
||||
constrsNode (N (_,_,_,(c,_),_)) = c
|
||||
metaSubstsNode (N (_,_,_,(_,m),_)) = m
|
||||
|
||||
atomTree :: Tree -> Atom
|
||||
valTree :: Tree -> Val
|
||||
|
||||
atomTree = atomNode . nodeTree
|
||||
valTree = valNode . nodeTree
|
||||
|
||||
mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode
|
||||
mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
|
||||
|
||||
type Var = Ident
|
||||
type Meta = MetaSymb
|
||||
|
||||
metasTree :: Tree -> [Meta]
|
||||
metasTree = concatMap metasNode . scanTree where
|
||||
metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n)
|
||||
|
||||
varsTree :: Tree -> [(Var,Val)]
|
||||
varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t]
|
||||
|
||||
constrsTree :: Tree -> Constraints
|
||||
constrsTree = constrsNode . nodeTree
|
||||
|
||||
allConstrsTree :: Tree -> Constraints
|
||||
allConstrsTree = concatMap constrsNode . scanTree
|
||||
|
||||
changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode
|
||||
changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x)
|
||||
|
||||
changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode
|
||||
changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
|
||||
|
||||
changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
|
||||
changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
|
||||
|
||||
-- * on the way to Edit
|
||||
|
||||
uTree :: Tree
|
||||
uTree = Tr (uNode, []) -- unknown tree
|
||||
|
||||
uNode :: TrNode
|
||||
uNode = mkNode [] uAtom uVal ([],[])
|
||||
|
||||
|
||||
uAtom :: Atom
|
||||
uAtom = AtM meta0
|
||||
|
||||
mAtom :: Atom
|
||||
mAtom = AtM meta0
|
||||
|
||||
uVal :: Val
|
||||
uVal = vClos uExp
|
||||
|
||||
vClos :: Exp -> Val
|
||||
vClos = VClos []
|
||||
|
||||
uExp :: Exp
|
||||
uExp = Meta meta0
|
||||
|
||||
mExp, mExp0 :: Exp
|
||||
mExp = Meta meta0
|
||||
mExp0 = mExp
|
||||
|
||||
meta2exp :: MetaSymb -> Exp
|
||||
meta2exp = Meta
|
||||
|
||||
atomC :: Fun -> Atom
|
||||
atomC = AtC
|
||||
|
||||
funAtom :: Atom -> Err Fun
|
||||
funAtom a = case a of
|
||||
AtC f -> return f
|
||||
_ -> prtBad "not function head" a
|
||||
|
||||
atomIsMeta :: Atom -> Bool
|
||||
atomIsMeta atom = case atom of
|
||||
AtM _ -> True
|
||||
_ -> False
|
||||
|
||||
getMetaAtom :: Atom -> Err Meta
|
||||
getMetaAtom a = case a of
|
||||
AtM m -> return m
|
||||
_ -> Bad "the active node is not meta"
|
||||
|
||||
cat2val :: Context -> Cat -> Val
|
||||
cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]]
|
||||
|
||||
val2cat :: Val -> Err Cat
|
||||
val2cat v = val2exp v >>= valCat
|
||||
|
||||
substTerm :: [Ident] -> Substitution -> Term -> Term
|
||||
substTerm ss g c = case c of
|
||||
Vr x -> maybe c id $ lookup x g
|
||||
App f a -> App (substTerm ss g f) (substTerm ss g a)
|
||||
Abs x b -> let y = mkFreshVarX ss x in
|
||||
Abs y (substTerm (y:ss) ((x, Vr y):g) b)
|
||||
Prod x a b -> let y = mkFreshVarX ss x in
|
||||
Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b)
|
||||
_ -> c
|
||||
|
||||
metaSubstExp :: MetaSubst -> [(Meta,Exp)]
|
||||
metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
|
||||
|
||||
-- * belong here rather than to computation
|
||||
|
||||
substitute :: [Var] -> Substitution -> Exp -> Err Exp
|
||||
substitute v s = return . substTerm v s
|
||||
|
||||
alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp ---
|
||||
alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
|
||||
|
||||
alphaFresh :: [Var] -> Exp -> Err Exp
|
||||
alphaFresh vs = refreshTermN $ maxVarIndex vs
|
||||
|
||||
-- | done in a state monad
|
||||
alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
|
||||
alphaFreshAll vs = mapM $ alphaFresh vs
|
||||
|
||||
-- | for display
|
||||
val2exp :: Val -> Err Exp
|
||||
val2exp = val2expP False
|
||||
|
||||
-- | for type checking
|
||||
val2expSafe :: Val -> Err Exp
|
||||
val2expSafe = val2expP True
|
||||
|
||||
val2expP :: Bool -> Val -> Err Exp
|
||||
val2expP safe v = case v of
|
||||
|
||||
VClos g@(_:_) e@(Meta _) -> if safe
|
||||
then prtBad "unsafe value substitution" v
|
||||
else substVal g e
|
||||
VClos g e -> substVal g e
|
||||
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
|
||||
VCn c -> return $ qq c
|
||||
VGen i x -> if safe
|
||||
then prtBad "unsafe val2exp" v
|
||||
else return $ Vr $ x --- in editing, no alpha conversions presentv
|
||||
where
|
||||
substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
|
||||
|
||||
isConstVal :: Val -> Bool
|
||||
isConstVal v = case v of
|
||||
VApp f c -> isConstVal f && isConstVal c
|
||||
VCn _ -> True
|
||||
VClos [] e -> null $ freeVarsExp e
|
||||
_ -> False --- could be more liberal
|
||||
|
||||
mkProdVal :: Binds -> Val -> Err Val ---
|
||||
mkProdVal bs v = do
|
||||
bs' <- mapPairsM val2exp bs
|
||||
v' <- val2exp v
|
||||
return $ vClos $ foldr (uncurry Prod) v' bs'
|
||||
|
||||
freeVarsExp :: Exp -> [Ident]
|
||||
freeVarsExp e = case e of
|
||||
Vr x -> [x]
|
||||
App f c -> freeVarsExp f ++ freeVarsExp c
|
||||
Abs x b -> filter (/=x) (freeVarsExp b)
|
||||
Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
|
||||
_ -> [] --- thus applies to abstract syntax only
|
||||
|
||||
ident2string :: Ident -> String
|
||||
ident2string = prIdent
|
||||
|
||||
tree :: (TrNode,[Tree]) -> Tree
|
||||
tree = Tr
|
||||
|
||||
eqCat :: Cat -> Cat -> Bool
|
||||
eqCat = (==)
|
||||
|
||||
addBinds :: Binds -> Tree -> Tree
|
||||
addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts)
|
||||
|
||||
bodyTree :: Tree -> Tree
|
||||
bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts)
|
||||
|
||||
refreshMetas :: [Meta] -> Exp -> Exp
|
||||
refreshMetas metas = fst . rms minMeta where
|
||||
rms meta trm = case trm of
|
||||
Meta m -> (Meta meta, nextMeta meta)
|
||||
App f a -> let (f',msf) = rms meta f
|
||||
(a',msa) = rms msf a
|
||||
in (App f' a', msa)
|
||||
Prod x a b ->
|
||||
let (a',msa) = rms meta a
|
||||
(b',msb) = rms msa b
|
||||
in (Prod x a' b', msb)
|
||||
Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
|
||||
_ -> (trm,meta)
|
||||
minMeta = int2meta $
|
||||
if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
|
||||
|
||||
ref2exp :: [Var] -> Type -> Ref -> Err Exp
|
||||
ref2exp bounds typ ref = do
|
||||
cont <- contextOfType typ
|
||||
xx0 <- mapM (typeSkeleton . snd) cont
|
||||
let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0]
|
||||
args = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds]
|
||||
return $ mkApp ref args
|
||||
-- no refreshment of metas
|
||||
|
||||
-- | invariant: only 'Con' or 'Var'
|
||||
type Ref = Exp
|
||||
|
||||
fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp
|
||||
fun2wrap oldvars ((fun,i),typ) exp = do
|
||||
cont <- contextOfType typ
|
||||
args <- mapM mkArg (zip [0..] (map snd cont))
|
||||
return $ mkApp (qq fun) args
|
||||
where
|
||||
mkArg (n,c) = do
|
||||
cont <- contextOfType c
|
||||
let vars = mkFreshVars (length cont) oldvars
|
||||
return $ mkAbs vars $ if n==i then exp else mExp
|
||||
|
||||
-- | weak heuristics: sameness of value category
|
||||
compatType :: Val -> Type -> Bool
|
||||
compatType v t = errVal True $ do
|
||||
cat1 <- val2cat v
|
||||
cat2 <- valCat t
|
||||
return $ cat1 == cat2
|
||||
|
||||
---
|
||||
|
||||
mkJustProd :: Context -> Term -> Term
|
||||
mkJustProd cont typ = mkProd (cont,typ,[])
|
||||
|
||||
int2var :: Int -> Ident
|
||||
int2var = identC . BS.pack . ('$':) . show
|
||||
|
||||
meta0 :: Meta
|
||||
meta0 = int2meta 0
|
||||
|
||||
termMeta0 :: Term
|
||||
termMeta0 = Meta meta0
|
||||
|
||||
identVar :: Term -> Err Ident
|
||||
identVar (Vr x) = return x
|
||||
identVar _ = Bad "not a variable"
|
||||
|
||||
|
||||
-- | light-weight rename for user interaction; also change names of internal vars
|
||||
qualifTerm :: Ident -> Term -> Term
|
||||
qualifTerm m = qualif [] where
|
||||
qualif xs t = case t of
|
||||
Abs x b -> let x' = chV x in Abs x' $ qualif (x':xs) b
|
||||
Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b
|
||||
Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q m x)
|
||||
Cn c -> Q m c
|
||||
Con c -> QC m c
|
||||
_ -> composSafeOp (qualif xs) t
|
||||
chV x = string2var $ ident2bs x
|
||||
|
||||
string2var :: BS.ByteString -> Ident
|
||||
string2var s = case BS.unpack s of
|
||||
c:'_':i -> identV (BS.singleton c) (readIntArg i) ---
|
||||
_ -> identC s
|
||||
|
||||
-- | reindex variables so that they tell nesting depth level
|
||||
reindexTerm :: Term -> Term
|
||||
reindexTerm = qualif (0,[]) where
|
||||
qualif dg@(d,g) t = case t of
|
||||
Abs x b -> let x' = ind x d in Abs x' $ qualif (d+1, (x,x'):g) b
|
||||
Prod x a b -> let x' = ind x d in Prod x' (qualif dg a) $ qualif (d+1, (x,x'):g) b
|
||||
Vr x -> Vr $ look x g
|
||||
_ -> composSafeOp (qualif dg) t
|
||||
look x = maybe x id . lookup x --- if x is not in scope it is unchanged
|
||||
ind x d = identC $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d)
|
||||
|
||||
|
||||
-- this method works for context-free abstract syntax
|
||||
-- and is meant to be used in simple embedded GF applications
|
||||
|
||||
exp2tree :: Exp -> Err Tree
|
||||
exp2tree e = do
|
||||
(bs,f,xs) <- termForm e
|
||||
cont <- case bs of
|
||||
[] -> return []
|
||||
_ -> prtBad "cannot convert bindings in" e
|
||||
at <- case f of
|
||||
Q m c -> return $ AtC (m,c)
|
||||
QC m c -> return $ AtC (m,c)
|
||||
Meta m -> return $ AtM m
|
||||
K s -> return $ AtL s
|
||||
EInt n -> return $ AtI n
|
||||
EFloat n -> return $ AtF n
|
||||
_ -> prtBad "cannot convert to atom" f
|
||||
ts <- mapM exp2tree xs
|
||||
return $ Tr (N (cont,at,uVal,([],[]),True),ts)
|
||||
733
src/GF/Grammar/Macros.hs
Normal file
733
src/GF/Grammar/Macros.hs
Normal file
@@ -0,0 +1,733 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Macros
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 16:38:00 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.24 $
|
||||
--
|
||||
-- Macros for constructing and analysing source code terms.
|
||||
--
|
||||
-- operations on terms and types not involving lookup in or reference to grammars
|
||||
--
|
||||
-- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Macros where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Str
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
import Control.Monad (liftM, liftM2)
|
||||
import Data.Char (isDigit)
|
||||
import Data.List (sortBy)
|
||||
|
||||
firstTypeForm :: Type -> Err (Context, Type)
|
||||
firstTypeForm t = case t of
|
||||
Prod x a b -> do
|
||||
(x', val) <- firstTypeForm b
|
||||
return ((x,a):x',val)
|
||||
_ -> return ([],t)
|
||||
|
||||
qTypeForm :: Type -> Err (Context, Cat, [Term])
|
||||
qTypeForm t = case t of
|
||||
Prod x a b -> do
|
||||
(x', cat, args) <- qTypeForm b
|
||||
return ((x,a):x', cat, args)
|
||||
App c a -> do
|
||||
(_,cat, args) <- qTypeForm c
|
||||
return ([],cat,args ++ [a])
|
||||
Q m c ->
|
||||
return ([],(m,c),[])
|
||||
QC m c ->
|
||||
return ([],(m,c),[])
|
||||
_ ->
|
||||
prtBad "no normal form of type" t
|
||||
|
||||
qq :: QIdent -> Term
|
||||
qq (m,c) = Q m c
|
||||
|
||||
typeForm :: Type -> Err (Context, Cat, [Term])
|
||||
typeForm = qTypeForm ---- no need to distinguish any more
|
||||
|
||||
typeFormCnc :: Type -> Err (Context, Type)
|
||||
typeFormCnc t = case t of
|
||||
Prod x a b -> do
|
||||
(x', v) <- typeFormCnc b
|
||||
return ((x,a):x',v)
|
||||
_ -> return ([],t)
|
||||
|
||||
valCat :: Type -> Err Cat
|
||||
valCat typ =
|
||||
do (_,cat,_) <- typeForm typ
|
||||
return cat
|
||||
|
||||
valType :: Type -> Err Type
|
||||
valType typ =
|
||||
do (_,cat,xx) <- typeForm typ --- not optimal to do in this way
|
||||
return $ mkApp (qq cat) xx
|
||||
|
||||
valTypeCnc :: Type -> Err Type
|
||||
valTypeCnc typ =
|
||||
do (_,ty) <- typeFormCnc typ
|
||||
return ty
|
||||
|
||||
typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
|
||||
typeRawSkeleton typ =
|
||||
do (cont,typ) <- typeFormCnc typ
|
||||
args <- mapM (typeRawSkeleton . snd) cont
|
||||
return ([(length c, v) | (c,v) <- args], typ)
|
||||
|
||||
type MCat = (Ident,Ident)
|
||||
|
||||
getMCat :: Term -> Err MCat
|
||||
getMCat t = case t of
|
||||
Q m c -> return (m,c)
|
||||
QC m c -> return (m,c)
|
||||
Sort c -> return (identW, c)
|
||||
App f _ -> getMCat f
|
||||
_ -> prtBad "no qualified constant" t
|
||||
|
||||
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
|
||||
typeSkeleton typ = do
|
||||
(cont,val) <- typeRawSkeleton typ
|
||||
cont' <- mapPairsM getMCat cont
|
||||
val' <- getMCat val
|
||||
return (cont',val')
|
||||
|
||||
catSkeleton :: Type -> Err ([MCat],MCat)
|
||||
catSkeleton typ =
|
||||
do (args,val) <- typeSkeleton typ
|
||||
return (map snd args, val)
|
||||
|
||||
funsToAndFrom :: Type -> (MCat, [(MCat,[Int])])
|
||||
funsToAndFrom t = errVal undefined $ do ---
|
||||
(cs,v) <- catSkeleton t
|
||||
let cis = zip cs [0..]
|
||||
return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
|
||||
|
||||
typeFormConcrete :: Type -> Err (Context, Type)
|
||||
typeFormConcrete t = case t of
|
||||
Prod x a b -> do
|
||||
(x', typ) <- typeFormConcrete b
|
||||
return ((x,a):x', typ)
|
||||
_ -> return ([],t)
|
||||
|
||||
isRecursiveType :: Type -> Bool
|
||||
isRecursiveType t = errVal False $ do
|
||||
(cc,c) <- catSkeleton t -- thus recursivity on Cat level
|
||||
return $ any (== c) cc
|
||||
|
||||
isHigherOrderType :: Type -> Bool
|
||||
isHigherOrderType t = errVal True $ do -- pessimistic choice
|
||||
co <- contextOfType t
|
||||
return $ not $ null [x | (x,Prod _ _ _) <- co]
|
||||
|
||||
contextOfType :: Type -> Err Context
|
||||
contextOfType typ = case typ of
|
||||
Prod x a b -> liftM ((x,a):) $ contextOfType b
|
||||
_ -> return []
|
||||
|
||||
unComputed :: Term -> Term
|
||||
unComputed t = case t of
|
||||
Computed v -> unComputed v
|
||||
_ -> t --- composSafeOp unComputed t
|
||||
|
||||
|
||||
{-
|
||||
--- defined (better) in compile/PrOld
|
||||
|
||||
stripTerm :: Term -> Term
|
||||
stripTerm t = case t of
|
||||
Q _ c -> Cn c
|
||||
QC _ c -> Cn c
|
||||
T ti psts -> T ti [(stripPatt p, stripTerm v) | (p,v) <- psts]
|
||||
_ -> composSafeOp stripTerm t
|
||||
where
|
||||
stripPatt p = errVal p $ term2patt $ stripTerm $ patt2term p
|
||||
-}
|
||||
|
||||
computed :: Term -> Term
|
||||
computed = Computed
|
||||
|
||||
termForm :: Term -> Err ([(Ident)], Term, [Term])
|
||||
termForm t = case t of
|
||||
Abs x b ->
|
||||
do (x', fun, args) <- termForm b
|
||||
return (x:x', fun, args)
|
||||
App c a ->
|
||||
do (_,fun, args) <- termForm c
|
||||
return ([],fun,args ++ [a])
|
||||
_ ->
|
||||
return ([],t,[])
|
||||
|
||||
termFormCnc :: Term -> ([(Ident)], Term)
|
||||
termFormCnc t = case t of
|
||||
Abs x b -> (x:xs, t') where (xs,t') = termFormCnc b
|
||||
_ -> ([],t)
|
||||
|
||||
appForm :: Term -> (Term, [Term])
|
||||
appForm t = case t of
|
||||
App c a -> (fun, args ++ [a]) where (fun, args) = appForm c
|
||||
_ -> (t,[])
|
||||
|
||||
varsOfType :: Type -> [Ident]
|
||||
varsOfType t = case t of
|
||||
Prod x _ b -> x : varsOfType b
|
||||
_ -> []
|
||||
|
||||
mkProdSimple :: Context -> Term -> Term
|
||||
mkProdSimple c t = mkProd (c,t,[])
|
||||
|
||||
mkProd :: (Context, Term, [Term]) -> Term
|
||||
mkProd ([],typ,args) = mkApp typ args
|
||||
mkProd ((x,a):dd, typ, args) = Prod x a (mkProd (dd, typ, args))
|
||||
|
||||
mkTerm :: ([(Ident)], Term, [Term]) -> Term
|
||||
mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)
|
||||
|
||||
mkApp :: Term -> [Term] -> Term
|
||||
mkApp = foldl App
|
||||
|
||||
mkAbs :: [Ident] -> Term -> Term
|
||||
mkAbs xx t = foldr 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 -> Ident -> Bool
|
||||
eqIdent = (==)
|
||||
|
||||
uType :: Type
|
||||
uType = Cn cUndefinedType
|
||||
|
||||
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]
|
||||
|
||||
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)
|
||||
|
||||
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]
|
||||
_ -> prtBad "record expected, found" t
|
||||
|
||||
typeType, typePType, typeStr, typeTok, typeStrs :: Term
|
||||
|
||||
typeType = Sort cType
|
||||
typePType = Sort cPType
|
||||
typeStr = Sort cStr
|
||||
typeTok = Sort cTok
|
||||
typeStrs = Sort cStrs
|
||||
|
||||
typeString, typeFloat, typeInt :: Term
|
||||
typeInts :: Integer -> Term
|
||||
typePBool :: Term
|
||||
typeError :: Term
|
||||
|
||||
typeString = cnPredef cString
|
||||
typeInt = cnPredef cInt
|
||||
typeFloat = cnPredef cFloat
|
||||
typeInts i = App (cnPredef cInts) (EInt i)
|
||||
typePBool = cnPredef cPBool
|
||||
typeError = cnPredef cErrorType
|
||||
|
||||
isTypeInts :: Term -> Maybe Integer
|
||||
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
|
||||
isTypeInts _ = Nothing
|
||||
|
||||
isPredefConstant :: Term -> Bool
|
||||
isPredefConstant t = case t of
|
||||
Q mod _ | mod == cPredef || mod == cPredefAbs -> True
|
||||
_ -> False
|
||||
|
||||
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 :: [Ident] -> Term -> Term
|
||||
mkCTable ids v = foldr ccase v ids where
|
||||
ccase x t = T TRaw [(PV x,t)]
|
||||
|
||||
mkDecl :: Term -> Decl
|
||||
mkDecl typ = (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 ([(identW, ty) | ty <- tt], t, []) -- nondep prod
|
||||
|
||||
plusRecType :: Type -> Type -> Err Type
|
||||
plusRecType t1 t2 = case (unComputed t1, unComputed 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 prt ls)
|
||||
_ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt 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" +++ prt t1 +++ "and" +++ prt 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 :: Integer -> Term
|
||||
int2term = EInt
|
||||
|
||||
float2term :: Double -> Term
|
||||
float2term = EFloat
|
||||
|
||||
-- | create a terminal from identifier
|
||||
ident2terminal :: Ident -> Term
|
||||
ident2terminal = K . prIdent
|
||||
|
||||
symbolOfIdent :: Ident -> String
|
||||
symbolOfIdent = prIdent
|
||||
|
||||
symid :: Ident -> String
|
||||
symid = symbolOfIdent
|
||||
|
||||
justIdentOf :: Term -> Maybe Ident
|
||||
justIdentOf (Vr x) = Just x
|
||||
justIdentOf (Cn x) = Just x
|
||||
justIdentOf _ = Nothing
|
||||
|
||||
isMeta :: Term -> Bool
|
||||
isMeta (Meta _) = True
|
||||
isMeta _ = False
|
||||
|
||||
mkMeta :: Int -> Term
|
||||
mkMeta = Meta . MetaSymb
|
||||
|
||||
nextMeta :: MetaSymb -> MetaSymb
|
||||
nextMeta = int2meta . succ . metaSymbInt
|
||||
|
||||
int2meta :: Int -> MetaSymb
|
||||
int2meta = MetaSymb
|
||||
|
||||
metaSymbInt :: MetaSymb -> Int
|
||||
metaSymbInt (MetaSymb k) = k
|
||||
|
||||
freshMeta :: [MetaSymb] -> MetaSymb
|
||||
freshMeta ms = MetaSymb (minimum [n | n <- [0..length ms],
|
||||
notElem n (map metaSymbInt ms)])
|
||||
|
||||
mkFreshMetasInTrm :: [MetaSymb] -> Trm -> Trm
|
||||
mkFreshMetasInTrm metas = fst . rms minMeta where
|
||||
rms meta trm = case trm of
|
||||
Meta m -> (Meta (MetaSymb meta), meta + 1)
|
||||
App f a -> let (f',msf) = rms meta f
|
||||
(a',msa) = rms msf a
|
||||
in (App f' a', msa)
|
||||
Prod x a b ->
|
||||
let (a',msa) = rms meta a
|
||||
(b',msb) = rms msa b
|
||||
in (Prod x a' b', msb)
|
||||
Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
|
||||
_ -> (trm,meta)
|
||||
minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
|
||||
|
||||
-- | decides that a term has no metavariables
|
||||
isCompleteTerm :: Term -> Bool
|
||||
isCompleteTerm t = case t of
|
||||
Meta _ -> False
|
||||
Abs _ b -> isCompleteTerm b
|
||||
App f a -> isCompleteTerm f && isCompleteTerm a
|
||||
_ -> True
|
||||
|
||||
linTypeStr :: Type
|
||||
linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
|
||||
|
||||
linAsStr :: String -> Term
|
||||
linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
|
||||
|
||||
term2patt :: Term -> Err Patt
|
||||
term2patt trm = case termForm trm of
|
||||
Ok ([], Vr x, []) -> return (PV x)
|
||||
Ok ([], Val ty x, []) -> return (PVal ty x)
|
||||
Ok ([], Con c, aa) -> do
|
||||
aa' <- mapM term2patt aa
|
||||
return (PC c aa')
|
||||
Ok ([], QC p c, aa) -> do
|
||||
aa' <- mapM term2patt aa
|
||||
return (PP p c aa')
|
||||
|
||||
Ok ([], Q p c, []) -> do
|
||||
return (PM p 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)
|
||||
|
||||
_ -> prtBad "no pattern corresponds to term" trm
|
||||
|
||||
patt2term :: Patt -> Term
|
||||
patt2term pt = case pt of
|
||||
PV x -> Vr x
|
||||
PW -> Vr identW --- not parsable, should not occur
|
||||
PVal t i -> Val t i
|
||||
PMacro c -> Cn c
|
||||
PM p c -> Q p c
|
||||
|
||||
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 -> 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
|
||||
|
||||
|
||||
redirectTerm :: Ident -> 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 unComputed 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 unComputed 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 <- combinations v0]
|
||||
]
|
||||
FV ts -> mapM strsFromTerm ts >>= return . concat
|
||||
Strs ts -> mapM strsFromTerm ts >>= return . concat
|
||||
Ready ss -> return [ss]
|
||||
Alias _ _ d -> strsFromTerm d --- should not be needed...
|
||||
_ -> prtBad "cannot get Str from term" t
|
||||
|
||||
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
|
||||
stringFromTerm :: Term -> String
|
||||
stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
|
||||
|
||||
|
||||
-- | 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 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')
|
||||
|
||||
TSh i cc ->
|
||||
do cc' <- mapPairListM (co . snd) cc
|
||||
i' <- changeTableType co i
|
||||
return (TSh 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')
|
||||
|
||||
Val ty i ->
|
||||
do ty' <- co ty
|
||||
return (Val ty' i)
|
||||
|
||||
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')
|
||||
Alias c ty d ->
|
||||
do v <- co d
|
||||
ty' <- co ty
|
||||
return $ Alias c ty' v
|
||||
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
|
||||
Strs tt -> mapM co tt >>= return . Strs
|
||||
|
||||
EPattType ty ->
|
||||
do ty' <- co ty
|
||||
return (EPattType ty')
|
||||
|
||||
_ -> return trm -- covers K, Vr, Cn, Sort, EPatt
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
TSh _ 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
|
||||
Strs tt -> concatMap co tt
|
||||
_ -> [] -- covers K, Vr, Cn, Sort, Ready
|
||||
|
||||
-- | 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
|
||||
Ready s -> allItems s
|
||||
_ -> collectOp wo trm
|
||||
where wo = wordsInTerm
|
||||
|
||||
noExist :: Term
|
||||
noExist = FV []
|
||||
|
||||
defaultLinType :: Type
|
||||
defaultLinType = mkRecType linLabel [typeStr]
|
||||
|
||||
metaTerms :: [Term]
|
||||
metaTerms = map (Meta . MetaSymb) [0..]
|
||||
|
||||
-- | from GF1, 20\/9\/2003
|
||||
isInOneType :: Type -> Bool
|
||||
isInOneType t = case t of
|
||||
Prod _ a b -> a == b
|
||||
_ -> False
|
||||
|
||||
-- normalize records and record types; put s first
|
||||
|
||||
sortRec :: [(Label,a)] -> [(Label,a)]
|
||||
sortRec = sortBy ordLabel where
|
||||
ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of
|
||||
("s",_) -> LT
|
||||
(_,"s") -> GT
|
||||
(s1,s2) -> compare s1 s2
|
||||
|
||||
|
||||
|
||||
155
src/GF/Grammar/PatternMatch.hs
Normal file
155
src/GF/Grammar/PatternMatch.hs
Normal file
@@ -0,0 +1,155 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : PatternMatch
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/12 12:38:29 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.PatternMatch (matchPattern,
|
||||
testOvershadow,
|
||||
findMatch
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
import Data.List
|
||||
import Control.Monad
|
||||
|
||||
|
||||
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
|
||||
matchPattern pts term =
|
||||
if not (isInConstantForm term)
|
||||
then prtBad "variables occur in" term
|
||||
else
|
||||
errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
|
||||
findMatch [([p],t) | (p,t) <- pts] [term]
|
||||
|
||||
testOvershadow :: [Patt] -> [Term] -> Err [Patt]
|
||||
testOvershadow pts vs = do
|
||||
let numpts = zip pts [0..]
|
||||
let cases = [(p,EInt i) | (p,i) <- numpts]
|
||||
ts <- mapM (liftM fst . matchPattern cases) vs
|
||||
return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
|
||||
|
||||
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
|
||||
findMatch cases terms = case cases of
|
||||
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
|
||||
(patts,_):_ | length patts /= length terms ->
|
||||
Bad ("wrong number of args for patterns :" +++
|
||||
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
|
||||
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
|
||||
Ok substs -> return (val, concat substs)
|
||||
_ -> findMatch cc terms
|
||||
|
||||
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
|
||||
tryMatch (p,t) = do
|
||||
t' <- termForm t
|
||||
trym p t'
|
||||
where
|
||||
isInConstantFormt = True -- tested already
|
||||
trym p t' =
|
||||
case (p,t') of
|
||||
(PVal _ i, (_,Val _ j,_))
|
||||
| i == j -> return []
|
||||
| otherwise -> Bad $ "no match of values"
|
||||
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
|
||||
(PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
|
||||
(PV x, _) | isInConstantFormt -> return [(x,t)]
|
||||
(PString s, ([],K i,[])) | s==i -> return []
|
||||
(PInt s, ([],EInt i,[])) | s==i -> return []
|
||||
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
|
||||
(PC p pp, ([], Con f, tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PP q p pp, ([], QC r f, tt)) |
|
||||
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
---- hack for AppPredef bug
|
||||
(PP q p pp, ([], Q r f, tt)) |
|
||||
-- q `eqStrIdent` r && ---
|
||||
p `eqStrIdent` f && length pp == length tt ->
|
||||
do matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
|
||||
(PR r, ([],R r',[])) |
|
||||
all (`elem` map fst r') (map fst r) ->
|
||||
do matches <- mapM tryMatch
|
||||
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
|
||||
return (concat matches)
|
||||
(PT _ p',_) -> trym p' t'
|
||||
(_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
|
||||
|
||||
-- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
|
||||
|
||||
(PAs x p',_) -> do
|
||||
subst <- trym p' t'
|
||||
return $ (x,t) : subst
|
||||
|
||||
(PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
|
||||
|
||||
(PNeg p',_) -> case tryMatch (p',t) of
|
||||
Bad _ -> return []
|
||||
_ -> prtBad "no match with negative pattern" p
|
||||
|
||||
(PSeq p1 p2, ([],K s, [])) -> do
|
||||
let cuts = [splitAt n s | n <- [0 .. length s]]
|
||||
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
|
||||
return (concat matches)
|
||||
|
||||
(PRep p1, ([],K s, [])) -> checks [
|
||||
trym (foldr (const (PSeq p1)) (PString "")
|
||||
[1..n]) t' | n <- [0 .. length s]
|
||||
] >>
|
||||
return []
|
||||
|
||||
(PChar, ([],K [_], [])) -> return []
|
||||
(PChars cs, ([],K [c], [])) | elem c cs -> return []
|
||||
|
||||
_ -> prtBad "no match in case expr for" t
|
||||
|
||||
isInConstantForm :: Term -> Bool
|
||||
isInConstantForm trm = case trm of
|
||||
Cn _ -> True
|
||||
Con _ -> True
|
||||
Q _ _ -> True
|
||||
QC _ _ -> True
|
||||
Abs _ _ -> True
|
||||
App c a -> isInConstantForm c && isInConstantForm a
|
||||
R r -> all (isInConstantForm . snd . snd) r
|
||||
K _ -> True
|
||||
Empty -> True
|
||||
Alias _ _ t -> isInConstantForm t
|
||||
EInt _ -> True
|
||||
_ -> False ---- isInArgVarForm trm
|
||||
|
||||
varsOfPatt :: Patt -> [Ident]
|
||||
varsOfPatt p = case p of
|
||||
PV x -> [x | not (isWildIdent x)]
|
||||
PC _ ps -> concat $ map varsOfPatt ps
|
||||
PP _ _ ps -> concat $ map varsOfPatt ps
|
||||
PR r -> concat $ map (varsOfPatt . snd) r
|
||||
PT _ q -> varsOfPatt q
|
||||
_ -> []
|
||||
|
||||
-- | to search matching parameter combinations in tables
|
||||
isMatchingForms :: [Patt] -> [Term] -> Bool
|
||||
isMatchingForms ps ts = all match (zip ps ts') where
|
||||
match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
|
||||
match _ = True
|
||||
ts' = map appForm ts
|
||||
|
||||
279
src/GF/Grammar/PrGrammar.hs
Normal file
279
src/GF/Grammar/PrGrammar.hs
Normal file
@@ -0,0 +1,279 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : PrGrammar
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/04 11:45:38 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.16 $
|
||||
--
|
||||
-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003
|
||||
--
|
||||
-- printing and prettyprinting class
|
||||
--
|
||||
-- 8\/1\/2004:
|
||||
-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
|
||||
-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
|
||||
-- only the former is ever needed.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.PrGrammar (Print(..),
|
||||
prtBad,
|
||||
prGrammar, prModule,
|
||||
prContext, prParam,
|
||||
prQIdent, prQIdent_,
|
||||
prRefinement, prTermOpt,
|
||||
prt_Tree, prMarkedTree, prTree,
|
||||
tree2string, prprTree,
|
||||
prConstrs, prConstraints,
|
||||
prMetaSubst, prEnv, prMSubst,
|
||||
prExp, prOperSignature,
|
||||
lookupIdent, lookupIdentInfo, lookupIdentInfoIn,
|
||||
prTermTabular
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Zipper
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Modules
|
||||
import qualified GF.Source.PrintGF as P
|
||||
import GF.Grammar.Values
|
||||
import GF.Source.GrammarToSource
|
||||
--- import GFC (CanonGrammar) --- cycle of modules
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.Ident
|
||||
import GF.Data.Str
|
||||
|
||||
import GF.Infra.CompactPrint
|
||||
|
||||
import Data.List (intersperse)
|
||||
|
||||
class Print a where
|
||||
prt :: a -> String
|
||||
-- | printing with parentheses, if needed
|
||||
prt2 :: a -> String
|
||||
-- | pretty printing
|
||||
prpr :: a -> [String]
|
||||
-- | printing without ident qualifications
|
||||
prt_ :: a -> String
|
||||
prt2 = prt
|
||||
prt_ = prt
|
||||
prpr = return . prt
|
||||
|
||||
-- 8/1/2004
|
||||
--- Usually followed principle: prt_ for displaying in the editor, prt
|
||||
--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
|
||||
--- only the former is ever needed.
|
||||
|
||||
-- | to show terms etc in error messages
|
||||
prtBad :: Print a => String -> a -> Err b
|
||||
prtBad s a = Bad (s +++ prt a)
|
||||
|
||||
pprintTree :: P.Print a => a -> String
|
||||
pprintTree = compactPrint . P.printTree
|
||||
|
||||
prGrammar :: SourceGrammar -> String
|
||||
prGrammar = pprintTree . trGrammar
|
||||
|
||||
prModule :: (Ident, SourceModInfo) -> String
|
||||
prModule = pprintTree . trModule
|
||||
|
||||
instance Print Term where
|
||||
prt = pprintTree . trt
|
||||
prt_ = prExp
|
||||
|
||||
instance Print Ident where
|
||||
prt = pprintTree . tri
|
||||
|
||||
instance Print Patt where
|
||||
prt = pprintTree . trp
|
||||
prt_ = prt . unqual where
|
||||
unqual p = case p of
|
||||
PP _ c [] -> PV c --- to remove curlies
|
||||
PP _ c ps -> PC c (map unqual ps)
|
||||
PC c ps -> PC c (map unqual ps)
|
||||
_ -> p ---- records
|
||||
|
||||
instance Print Label where
|
||||
prt = pprintTree . trLabel
|
||||
|
||||
instance Print MetaSymb where
|
||||
prt (MetaSymb i) = "?" ++ show i
|
||||
|
||||
prParam :: Param -> String
|
||||
prParam (c,co) = prt c +++ prContext co
|
||||
|
||||
prContext :: Context -> String
|
||||
prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
|
||||
|
||||
-- some GFC notions
|
||||
|
||||
instance Print a => Print (Tr a) where
|
||||
prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
|
||||
prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
|
||||
|
||||
-- | we cannot define the method prt_ in this way
|
||||
prt_Tree :: Tree -> String
|
||||
prt_Tree = prt_ . tree2exp
|
||||
|
||||
instance Print TrNode where
|
||||
prt (N (bi,at,vt,(cs,ms),_)) =
|
||||
prBinds bi ++
|
||||
prt at +++ ":" +++ prt vt
|
||||
+++ prConstraints cs +++ prMetaSubst ms
|
||||
prt_ (N (bi,at,vt,(cs,ms),_)) =
|
||||
prBinds bi ++
|
||||
prt_ at +++ ":" +++ prt_ vt
|
||||
+++ prConstraints cs +++ prMetaSubst ms
|
||||
|
||||
prMarkedTree :: Tr (TrNode,Bool) -> [String]
|
||||
prMarkedTree = prf 1 where
|
||||
prf ind t@(Tr (node, trees)) =
|
||||
prNode ind node : concatMap (prf (ind + 2)) trees
|
||||
prNode ind node = case node of
|
||||
(n, False) -> indent ind (prt_ n)
|
||||
(n, _) -> '*' : indent (ind - 1) (prt_ n)
|
||||
|
||||
prTree :: Tree -> [String]
|
||||
prTree = prMarkedTree . mapTr (\n -> (n,False))
|
||||
|
||||
-- | a pretty-printer for parsable output
|
||||
tree2string :: Tree -> String
|
||||
tree2string = unlines . prprTree
|
||||
|
||||
prprTree :: Tree -> [String]
|
||||
prprTree = prf False where
|
||||
prf par t@(Tr (node, trees)) =
|
||||
parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
|
||||
prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
|
||||
prb [] = ""
|
||||
prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
|
||||
parIf par (s:ss) = map (indent 2) $
|
||||
if par
|
||||
then ('(':s) : ss ++ [")"]
|
||||
else s:ss
|
||||
ifPar (Tr (N ([],_,_,_,_), [])) = False
|
||||
ifPar _ = True
|
||||
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
prConstraints :: Constraints -> String
|
||||
prConstraints = concat . prConstrs
|
||||
|
||||
prMetaSubst :: MetaSubst -> String
|
||||
prMetaSubst = concat . prMSubst
|
||||
|
||||
prEnv :: Env -> String
|
||||
---- prEnv [] = prCurly "" ---- for debugging
|
||||
prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
|
||||
|
||||
prConstrs :: Constraints -> [String]
|
||||
prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
|
||||
|
||||
prMSubst :: MetaSubst -> [String]
|
||||
prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
|
||||
|
||||
prBinds bi = if null bi
|
||||
then []
|
||||
else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
|
||||
where
|
||||
prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
|
||||
|
||||
instance Print Val where
|
||||
prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
|
||||
prt (VApp u v) = prt u +++ prv1 v
|
||||
prt (VCn mc) = prQIdent_ mc
|
||||
prt (VClos env e) = case e of
|
||||
Meta _ -> prt_ e ++ prEnv env
|
||||
_ -> prt_ e ---- ++ prEnv env ---- for debugging
|
||||
prt VType = "Type"
|
||||
|
||||
prv1 v = case v of
|
||||
VApp _ _ -> prParenth $ prt v
|
||||
VClos _ _ -> prParenth $ prt v
|
||||
_ -> prt v
|
||||
|
||||
instance Print Atom where
|
||||
prt (AtC f) = prQIdent f
|
||||
prt (AtM i) = prt i
|
||||
prt (AtV i) = prt i
|
||||
prt (AtL s) = prQuotedString s
|
||||
prt (AtI i) = show i
|
||||
prt (AtF i) = show i
|
||||
prt_ (AtC (_,f)) = prt f
|
||||
prt_ a = prt a
|
||||
|
||||
prQIdent :: QIdent -> String
|
||||
prQIdent (m,f) = prt m ++ "." ++ prt f
|
||||
|
||||
prQIdent_ :: QIdent -> String
|
||||
prQIdent_ (_,f) = prt f
|
||||
|
||||
-- | print terms without qualifications
|
||||
prExp :: Term -> String
|
||||
prExp e = case e of
|
||||
App f a -> pr1 f +++ pr2 a
|
||||
Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b
|
||||
Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
|
||||
Q _ c -> prt c
|
||||
QC _ c -> prt c
|
||||
_ -> prt e
|
||||
where
|
||||
pr1 e = case e of
|
||||
Abs _ _ -> prParenth $ prExp e
|
||||
Prod _ _ _ -> prParenth $ prExp e
|
||||
_ -> prExp e
|
||||
pr2 e = case e of
|
||||
App _ _ -> prParenth $ prExp e
|
||||
_ -> pr1 e
|
||||
|
||||
-- | option @-strip@ strips qualifications
|
||||
prTermOpt :: Options -> Term -> String
|
||||
prTermOpt opts = if PrinterStrip `elem` flag optPrinter opts then prt else prExp
|
||||
|
||||
-- | to get rid of brackets in the editor
|
||||
prRefinement :: Term -> String
|
||||
prRefinement t = case t of
|
||||
Q m c -> prQIdent (m,c)
|
||||
QC m c -> prQIdent (m,c)
|
||||
_ -> prt t
|
||||
|
||||
prOperSignature :: (QIdent,Type) -> String
|
||||
prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
|
||||
|
||||
-- to look up a constant etc in a search tree --- why here? AR 29/5/2008
|
||||
|
||||
lookupIdent :: Ident -> BinTree Ident b -> Err b
|
||||
lookupIdent c t = case lookupTree prt c t of
|
||||
Ok v -> return v
|
||||
_ -> prtBad "unknown identifier" c
|
||||
|
||||
lookupIdentInfo :: Module Ident a -> Ident -> Err a
|
||||
lookupIdentInfo mo i = lookupIdent i (jments mo)
|
||||
|
||||
lookupIdentInfoIn :: Module Ident a -> Ident -> Ident -> Err a
|
||||
lookupIdentInfoIn mo m i =
|
||||
err (\s -> Bad (s +++ "in module" +++ prt m)) return $ lookupIdentInfo mo i
|
||||
|
||||
|
||||
--- printing cc command output AR 26/5/2008
|
||||
|
||||
prTermTabular :: Term -> [(String,String)]
|
||||
prTermTabular = pr where
|
||||
pr t = case t of
|
||||
R rs ->
|
||||
[(prt_ lab +++ "." +++ path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
|
||||
T _ cs ->
|
||||
[(prt_ lab +++"=>" +++ path, str) | (lab, val) <- cs, (path,str) <- pr val]
|
||||
V _ cs ->
|
||||
[("#" ++ show i +++"=>" +++ path, str) | (i,val) <- zip [0..] cs, (path,str) <- pr val]
|
||||
_ -> [([],ps t)]
|
||||
ps t = case t of
|
||||
K s -> s
|
||||
C s u -> ps s +++ ps u
|
||||
FV ts -> unwords (intersperse "/" (map ps ts))
|
||||
_ -> prt_ t
|
||||
177
src/GF/Grammar/Predef.hs
Normal file
177
src/GF/Grammar/Predef.hs
Normal file
@@ -0,0 +1,177 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : GF.Grammar.Predef
|
||||
-- Maintainer : kr.angelov
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- Predefined identifiers and labels which the compiler knows
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Grammar.Predef
|
||||
( cType
|
||||
, cPType
|
||||
, cTok
|
||||
, cStr
|
||||
, cStrs
|
||||
, cPredefAbs, cPredef
|
||||
, cInt
|
||||
, cFloat
|
||||
, cString
|
||||
, cInts
|
||||
, cPBool
|
||||
, cErrorType
|
||||
, cOverload
|
||||
, cUndefinedType
|
||||
, isPredefCat
|
||||
|
||||
, cPTrue, cPFalse
|
||||
|
||||
, cLength, cDrop, cTake, cTk, cDp, cEqStr, cOccur
|
||||
, cOccurs, cEqInt, cLessInt, cPlus, cShow, cRead
|
||||
, cToStr, cMapStr, cError
|
||||
|
||||
-- hacks
|
||||
, cMeta, cAs, cChar, cChars, cSeq, cAlt, cRep
|
||||
, cNeg, cCNC, cConflict
|
||||
) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
cType :: Ident
|
||||
cType = identC (BS.pack "Type")
|
||||
|
||||
cPType :: Ident
|
||||
cPType = identC (BS.pack "PType")
|
||||
|
||||
cTok :: Ident
|
||||
cTok = identC (BS.pack "Tok")
|
||||
|
||||
cStr :: Ident
|
||||
cStr = identC (BS.pack "Str")
|
||||
|
||||
cStrs :: Ident
|
||||
cStrs = identC (BS.pack "Strs")
|
||||
|
||||
cPredefAbs :: Ident
|
||||
cPredefAbs = identC (BS.pack "PredefAbs")
|
||||
|
||||
cPredef :: Ident
|
||||
cPredef = identC (BS.pack "Predef")
|
||||
|
||||
cInt :: Ident
|
||||
cInt = identC (BS.pack "Int")
|
||||
|
||||
cFloat :: Ident
|
||||
cFloat = identC (BS.pack "Float")
|
||||
|
||||
cString :: Ident
|
||||
cString = identC (BS.pack "String")
|
||||
|
||||
cInts :: Ident
|
||||
cInts = identC (BS.pack "Ints")
|
||||
|
||||
cPBool :: Ident
|
||||
cPBool = identC (BS.pack "PBool")
|
||||
|
||||
cErrorType :: Ident
|
||||
cErrorType = identC (BS.pack "Error")
|
||||
|
||||
cOverload :: Ident
|
||||
cOverload = identC (BS.pack "overload")
|
||||
|
||||
cUndefinedType :: Ident
|
||||
cUndefinedType = identC (BS.pack "UndefinedType")
|
||||
|
||||
isPredefCat :: Ident -> Bool
|
||||
isPredefCat c = elem c [cInt,cString,cFloat]
|
||||
|
||||
cPTrue :: Ident
|
||||
cPTrue = identC (BS.pack "PTrue")
|
||||
|
||||
cPFalse :: Ident
|
||||
cPFalse = identC (BS.pack "PFalse")
|
||||
|
||||
cLength :: Ident
|
||||
cLength = identC (BS.pack "length")
|
||||
|
||||
cDrop :: Ident
|
||||
cDrop = identC (BS.pack "drop")
|
||||
|
||||
cTake :: Ident
|
||||
cTake = identC (BS.pack "take")
|
||||
|
||||
cTk :: Ident
|
||||
cTk = identC (BS.pack "tk")
|
||||
|
||||
cDp :: Ident
|
||||
cDp = identC (BS.pack "dp")
|
||||
|
||||
cEqStr :: Ident
|
||||
cEqStr = identC (BS.pack "eqStr")
|
||||
|
||||
cOccur :: Ident
|
||||
cOccur = identC (BS.pack "occur")
|
||||
|
||||
cOccurs :: Ident
|
||||
cOccurs = identC (BS.pack "occurs")
|
||||
|
||||
cEqInt :: Ident
|
||||
cEqInt = identC (BS.pack "eqInt")
|
||||
|
||||
cLessInt :: Ident
|
||||
cLessInt = identC (BS.pack "lessInt")
|
||||
|
||||
cPlus :: Ident
|
||||
cPlus = identC (BS.pack "plus")
|
||||
|
||||
cShow :: Ident
|
||||
cShow = identC (BS.pack "show")
|
||||
|
||||
cRead :: Ident
|
||||
cRead = identC (BS.pack "read")
|
||||
|
||||
cToStr :: Ident
|
||||
cToStr = identC (BS.pack "toStr")
|
||||
|
||||
cMapStr :: Ident
|
||||
cMapStr = identC (BS.pack "mapStr")
|
||||
|
||||
cError :: Ident
|
||||
cError = identC (BS.pack "error")
|
||||
|
||||
|
||||
--- hacks: dummy identifiers used in various places
|
||||
--- Not very nice!
|
||||
|
||||
cMeta :: Ident
|
||||
cMeta = identC (BS.singleton '?')
|
||||
|
||||
cAs :: Ident
|
||||
cAs = identC (BS.singleton '@')
|
||||
|
||||
cChar :: Ident
|
||||
cChar = identC (BS.singleton '?')
|
||||
|
||||
cChars :: Ident
|
||||
cChars = identC (BS.pack "[]")
|
||||
|
||||
cSeq :: Ident
|
||||
cSeq = identC (BS.pack "+")
|
||||
|
||||
cAlt :: Ident
|
||||
cAlt = identC (BS.pack "|")
|
||||
|
||||
cRep :: Ident
|
||||
cRep = identC (BS.pack "*")
|
||||
|
||||
cNeg :: Ident
|
||||
cNeg = identC (BS.pack "-")
|
||||
|
||||
cCNC :: Ident
|
||||
cCNC = identC (BS.pack "CNC")
|
||||
|
||||
cConflict :: Ident
|
||||
cConflict = IC (BS.pack "#conflict")
|
||||
44
src/GF/Grammar/ReservedWords.hs
Normal file
44
src/GF/Grammar/ReservedWords.hs
Normal file
@@ -0,0 +1,44 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ReservedWords
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:28 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- reserved words of GF. (c) Aarne Ranta 19\/3\/2002 under Gnu GPL.
|
||||
-- modified by Markus Forsberg 9\/4.
|
||||
-- modified by AR 12\/6\/2003 for GF2 and GFC
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.ReservedWords (isResWord, isResWordGFC) where
|
||||
|
||||
import Data.List
|
||||
|
||||
|
||||
isResWord :: String -> Bool
|
||||
isResWord s = isInTree s resWordTree
|
||||
|
||||
resWordTree :: BTree
|
||||
resWordTree =
|
||||
-- mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords
|
||||
-- nowadays obtained from LexGF.hs
|
||||
B "let" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N))))
|
||||
|
||||
isResWordGFC :: String -> Bool
|
||||
isResWordGFC s = isInTree s $
|
||||
B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N)))
|
||||
|
||||
data BTree = N | B String BTree BTree deriving (Show)
|
||||
|
||||
isInTree :: String -> BTree -> Bool
|
||||
isInTree x tree = case tree of
|
||||
N -> False
|
||||
B a left right
|
||||
| x < a -> isInTree x left
|
||||
| x > a -> isInTree x right
|
||||
| x == a -> True
|
||||
|
||||
96
src/GF/Grammar/Unify.hs
Normal file
96
src/GF/Grammar/Unify.hs
Normal file
@@ -0,0 +1,96 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Unify
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:31 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
|
||||
--
|
||||
-- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
|
||||
-- the only use is in 'TypeCheck.splitConstraints'
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Unify (unifyVal) where
|
||||
|
||||
import GF.Grammar.Abstract
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.List (partition)
|
||||
|
||||
unifyVal :: Constraints -> Err (Constraints,MetaSubst)
|
||||
unifyVal cs0 = do
|
||||
let (cs1,cs2) = partition notSolvable cs0
|
||||
let (us,vs) = unzip cs1
|
||||
us' <- mapM val2exp us
|
||||
vs' <- mapM val2exp vs
|
||||
let (ms,cs) = unifyAll (zip us' vs') []
|
||||
return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs],
|
||||
[(m, VClos [] t) | (m,t) <- ms])
|
||||
where
|
||||
notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
|
||||
(VClos (_:_) _,_) -> True
|
||||
(_,VClos (_:_) _) -> True
|
||||
_ -> False
|
||||
|
||||
type Unifier = [(MetaSymb, Trm)]
|
||||
type Constrs = [(Trm, Trm)]
|
||||
|
||||
unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
|
||||
unifyAll [] g = (g, [])
|
||||
unifyAll ((a@(s, t)) : l) g =
|
||||
let (g1, c) = unifyAll l g
|
||||
in case unify s t g1 of
|
||||
Ok g2 -> (g2, c)
|
||||
_ -> (g1, a : c)
|
||||
|
||||
unify :: Trm -> Trm -> Unifier -> Err Unifier
|
||||
unify e1 e2 g =
|
||||
case (e1, e2) of
|
||||
(Meta s, t) -> do
|
||||
tg <- subst_all g t
|
||||
let sg = maybe e1 id (lookup s g)
|
||||
if (sg == Meta s) then extend g s tg else unify sg tg g
|
||||
(t, Meta s) -> unify e2 e1 g
|
||||
(Q _ a, Q _ b) | (a == b) -> return g ---- qualif?
|
||||
(QC _ a, QC _ b) | (a == b) -> return g ----
|
||||
(Vr x, Vr y) | (x == y) -> return g
|
||||
(Abs x b, Abs y c) -> do let c' = substTerm [x] [(y,Vr x)] c
|
||||
unify b c' g
|
||||
(App c a, App d b) -> case unify c d g of
|
||||
Ok g1 -> unify a b g1
|
||||
_ -> prtBad "fail unify" e1
|
||||
_ -> prtBad "fail unify" e1
|
||||
|
||||
extend :: Unifier -> MetaSymb -> Trm -> Err Unifier
|
||||
extend g s t | (t == Meta s) = return g
|
||||
| occCheck s t = prtBad "occurs check" t
|
||||
| True = return ((s, t) : g)
|
||||
|
||||
subst_all :: Unifier -> Trm -> Err Trm
|
||||
subst_all s u =
|
||||
case (s,u) of
|
||||
([], t) -> return t
|
||||
(a : l, t) -> do
|
||||
t' <- (subst_all l t) --- successive substs - why ?
|
||||
return $ substMetas [a] t'
|
||||
|
||||
substMetas :: [(MetaSymb,Trm)] -> Trm -> Trm
|
||||
substMetas subst trm = case trm of
|
||||
Meta x -> case lookup x subst of
|
||||
Just t -> t
|
||||
_ -> trm
|
||||
_ -> composSafeOp (substMetas subst) trm
|
||||
|
||||
occCheck :: MetaSymb -> Trm -> Bool
|
||||
occCheck s u = case u of
|
||||
Meta v -> s == v
|
||||
App c a -> occCheck s c || occCheck s a
|
||||
Abs x b -> occCheck s b
|
||||
_ -> False
|
||||
|
||||
91
src/GF/Grammar/Values.hs
Normal file
91
src/GF/Grammar/Values.hs
Normal file
@@ -0,0 +1,91 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Values
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:32 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Values (-- * values used in TC type checking
|
||||
Exp, Val(..), Env,
|
||||
-- * annotated tree used in editing
|
||||
Tree, TrNode(..), Atom(..), Binds, Constraints, MetaSubst,
|
||||
-- * for TC
|
||||
valAbsInt, valAbsFloat, valAbsString, vType,
|
||||
isPredefCat,
|
||||
eType, tree2exp, loc2treeFocus
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Zipper
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Predef
|
||||
|
||||
-- values used in TC type checking
|
||||
|
||||
type Exp = Term
|
||||
|
||||
data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VType | VClos Env Exp
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Env = [(Ident,Val)]
|
||||
|
||||
-- annotated tree used in editing
|
||||
|
||||
type Tree = Tr TrNode
|
||||
|
||||
newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool)
|
||||
deriving (Eq,Show)
|
||||
|
||||
data Atom =
|
||||
AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Integer | AtF Double
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Binds = [(Ident,Val)]
|
||||
type Constraints = [(Val,Val)]
|
||||
type MetaSubst = [(MetaSymb,Val)]
|
||||
|
||||
-- for TC
|
||||
|
||||
valAbsInt :: Val
|
||||
valAbsInt = VCn (cPredefAbs, cInt)
|
||||
|
||||
valAbsFloat :: Val
|
||||
valAbsFloat = VCn (cPredefAbs, cFloat)
|
||||
|
||||
valAbsString :: Val
|
||||
valAbsString = VCn (cPredefAbs, cString)
|
||||
|
||||
vType :: Val
|
||||
vType = VType
|
||||
|
||||
eType :: Exp
|
||||
eType = Sort cType
|
||||
|
||||
tree2exp :: Tree -> Exp
|
||||
tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
|
||||
at' = case at of
|
||||
AtC (m,c) -> Q m c
|
||||
AtV i -> Vr i
|
||||
AtM m -> Meta m
|
||||
AtL s -> K s
|
||||
AtI s -> EInt s
|
||||
AtF s -> EFloat s
|
||||
bi' = map fst bi
|
||||
ts' = map tree2exp ts
|
||||
|
||||
loc2treeFocus :: Loc TrNode -> Tree
|
||||
loc2treeFocus (Loc (Tr (a,ts),p)) =
|
||||
loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
|
||||
where
|
||||
(mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True),
|
||||
\(N (a,b,c,d,_)) -> N(a,b,c,d,False))
|
||||
|
||||
Reference in New Issue
Block a user