msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

clean up the GF.Grammar API

Browse Source
This commit is contained in:
krasimir
2009-09-14 16:23:23 +00:00
parent 9f3534b3bb
commit 14dfbcc624
20 changed files with 11 additions and 5904 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/GF/Command/Importing.hs
View File

@@ -5,10 +5,10 @@ import PGF.Data
import GF.Compile import GF.Compile
import GF.Grammar.Grammar (SourceGrammar) -- for cc command import GF.Grammar.Grammar (SourceGrammar) -- for cc command
import GF.Grammar.CF
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option
import GF.Data.ErrM import GF.Data.ErrM
import GF.Source.CF
import Data.List (nubBy) import Data.List (nubBy)
import System.FilePath import System.FilePath

4
src/GF/Compile.hs
View File

@@ -25,10 +25,6 @@ import GF.Infra.Option
import GF.Infra.Modules import GF.Infra.Modules
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Source.GrammarToSource
import qualified GF.Source.AbsGF as A
import qualified GF.Source.PrintGF as P
import GF.Data.Operations import GF.Data.Operations
import Control.Monad import Control.Monad

2
src/GF/Compile/AbsCompute.hs
View File

@@ -23,7 +23,7 @@ module GF.Compile.AbsCompute (LookDef,
import GF.Data.Operations import GF.Data.Operations
import GF.Grammar.Abstract import GF.Grammar
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Compile.Compute import GF.Compile.Compute

2
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -14,7 +14,7 @@ import GF.Grammar.Predef
import GF.Grammar.Printer import GF.Grammar.Printer
import GF.Grammar.Grammar import GF.Grammar.Grammar
import qualified GF.Grammar.Lookup as Look import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar.Abstract as A import qualified GF.Grammar as A
import qualified GF.Grammar.Macros as GM import qualified GF.Grammar.Macros as GM
import qualified GF.Compile.Compute as Compute ---- import qualified GF.Compile.Compute as Compute ----
import qualified GF.Infra.Modules as M import qualified GF.Infra.Modules as M

1
src/GF/Compile/ReadFiles.hs
View File

@@ -28,7 +28,6 @@ import GF.Infra.Option
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Modules import GF.Infra.Modules
import GF.Data.Operations import GF.Data.Operations
import qualified GF.Source.AbsGF as S
import GF.Grammar.Lexer import GF.Grammar.Lexer
import GF.Grammar.Parser import GF.Grammar.Parser
import GF.Grammar.Grammar import GF.Grammar.Grammar

3
src/GF/Compile/TC.hs
View File

@@ -22,9 +22,8 @@ module GF.Compile.TC (AExp(..),
) where ) where
import GF.Data.Operations import GF.Data.Operations
import GF.Grammar
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Abstract
import GF.Grammar.Printer
import Control.Monad import Control.Monad
import Data.List (sortBy) import Data.List (sortBy)

3
src/GF/Compile/TypeCheck.hs
View File

@@ -22,10 +22,9 @@ module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should n
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.CheckM import GF.Infra.CheckM
import GF.Grammar.Abstract import GF.Grammar
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Unify import GF.Grammar.Unify
import GF.Grammar.Printer
import GF.Compile.Refresh import GF.Compile.Refresh
import GF.Compile.AbsCompute import GF.Compile.AbsCompute
import GF.Compile.TC import GF.Compile.TC

4
src/GF/Grammar/Abstract.hs → src/GF/Grammar.hs
View File

@@ -12,12 +12,12 @@
-- (Description of the module) -- (Description of the module)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Grammar.Abstract ( module GF.Grammar (
module GF.Infra.Ident,
module GF.Grammar.Grammar, module GF.Grammar.Grammar,
module GF.Grammar.Values, module GF.Grammar.Values,
module GF.Grammar.Macros, module GF.Grammar.Macros,
module GF.Infra.Ident,
module GF.Grammar.MMacros, module GF.Grammar.MMacros,
module GF.Grammar.Printer, module GF.Grammar.Printer,

2
src/GF/Source/CF.hs → src/GF/Grammar/CF.hs
View File

@@ -12,7 +12,7 @@
-- parsing CF grammars and converting them to GF -- parsing CF grammars and converting them to GF
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Source.CF (getCF) where module GF.Grammar.CF (getCF) where
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Macros import GF.Grammar.Macros

3406
src/GF/Grammar/Parser.hs
View File

File diff suppressed because one or more lines are too long

255
src/GF/Grammar/PrGrammar.hs
View File

@@ -1,255 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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,
prConstrs,
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.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 :: SourceModule -> 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
prMetaSubst :: MetaSubst -> String
prMetaSubst = concat . prMSubst
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 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
-}
prEnv :: Env -> String
---- prEnv [] = prCurly "" ---- for debugging
prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
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 (VRecType xs) = prCurly (concat (intersperse "," [prt l ++ "=" ++ prt v | (l,v) <- xs]))
prt VType = "Type"
prv1 v = case v of
VApp _ _ -> prParenth $ prt v
VClos _ _ -> prParenth $ prt v
_ -> prt v
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
--- 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

2
src/GF/Grammar/Unify.hs
View File

@@ -17,7 +17,7 @@
module GF.Grammar.Unify (unifyVal) where module GF.Grammar.Unify (unifyVal) where
import GF.Grammar.Abstract import GF.Grammar
import GF.Data.Operations import GF.Data.Operations
import Text.PrettyPrint import Text.PrettyPrint

8
src/GF/Infra/Modules.hs
View File

@@ -33,7 +33,7 @@ module GF.Infra.Modules (
IdentM(..), IdentM(..),
abstractOfConcrete, abstractModOfConcrete, abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo, lookupModule, lookupModuleType, lookupInfo,
lookupPosition, showPosition, ppPosition, lookupPosition, ppPosition,
isModAbs, isModRes, isModCnc, isModTrans, isModAbs, isModRes, isModCnc, isModTrans,
sameMType, isCompilableModule, isCompleteModule, sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources, allAbstracts, greatestAbstract, allResources,
@@ -268,12 +268,6 @@ lookupInfo mo i = lookupTree show i (jments mo)
lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int)) lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree show i (positions mo) lookupPosition mo i = lookupTree show i (positions mo)
showPosition :: (Show i, Ord i) => ModInfo i a -> i -> String
showPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b
Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e
_ -> ""
ppPosition :: (Show i, Ord i) => ModInfo i a -> i -> Doc ppPosition :: (Show i, Ord i) => ModInfo i a -> i -> Doc
ppPosition mo i = case lookupPosition mo i of ppPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b

323
src/GF/Source/AbsGF.hs
View File

@@ -1,323 +0,0 @@
module GF.Source.AbsGF where
-- Haskell module generated by the BNF converter
import qualified Data.ByteString.Char8 as BS
newtype LString = LString BS.ByteString deriving (Eq,Ord,Show)
newtype PIdent = PIdent ((Int,Int),BS.ByteString) deriving (Eq,Ord,Show)
data Grammar =
Gr [ModDef]
deriving (Eq,Ord,Show)
data ModDef =
MMain PIdent PIdent [ConcSpec]
| MModule ComplMod ModType ModBody
deriving (Eq,Ord,Show)
data ConcSpec =
ConcSpec PIdent ConcExp
deriving (Eq,Ord,Show)
data ConcExp =
ConcExp PIdent [Transfer]
deriving (Eq,Ord,Show)
data Transfer =
TransferIn Open
| TransferOut Open
deriving (Eq,Ord,Show)
data ModHeader =
MModule2 ComplMod ModType ModHeaderBody
deriving (Eq,Ord,Show)
data ModHeaderBody =
MBody2 Extend Opens
| MNoBody2 [Included]
| MWith2 Included [Open]
| MWithBody2 Included [Open] Opens
| MWithE2 [Included] Included [Open]
| MWithEBody2 [Included] Included [Open] Opens
| MReuse2 PIdent
| MUnion2 [Included]
deriving (Eq,Ord,Show)
data ModType =
MTAbstract PIdent
| MTResource PIdent
| MTInterface PIdent
| MTConcrete PIdent PIdent
| MTInstance PIdent PIdent
| MTTransfer PIdent Open Open
deriving (Eq,Ord,Show)
data ModBody =
MBody Extend Opens [TopDef]
| MNoBody [Included]
| MWith Included [Open]
| MWithBody Included [Open] Opens [TopDef]
| MWithE [Included] Included [Open]
| MWithEBody [Included] Included [Open] Opens [TopDef]
| MReuse PIdent
| MUnion [Included]
deriving (Eq,Ord,Show)
data Extend =
Ext [Included]
| NoExt
deriving (Eq,Ord,Show)
data Opens =
NoOpens
| OpenIn [Open]
deriving (Eq,Ord,Show)
data Open =
OName PIdent
| OQualQO QualOpen PIdent
| OQual QualOpen PIdent PIdent
deriving (Eq,Ord,Show)
data ComplMod =
CMCompl
| CMIncompl
deriving (Eq,Ord,Show)
data QualOpen =
QOCompl
| QOIncompl
| QOInterface
deriving (Eq,Ord,Show)
data Included =
IAll PIdent
| ISome PIdent [PIdent]
| IMinus PIdent [PIdent]
deriving (Eq,Ord,Show)
data Def =
DDecl [Name] Exp
| DDef [Name] Exp
| DPatt Name [Patt] Exp
| DFull [Name] Exp Exp
deriving (Eq,Ord,Show)
data TopDef =
DefCat [CatDef]
| DefFun [FunDef]
| DefFunData [FunDef]
| DefDef [Def]
| DefData [DataDef]
| DefTrans [Def]
| DefPar [ParDef]
| DefOper [Def]
| DefLincat [PrintDef]
| DefLindef [Def]
| DefLin [Def]
| DefPrintCat [PrintDef]
| DefPrintFun [PrintDef]
| DefFlag [FlagDef]
| DefPrintOld [PrintDef]
| DefLintype [Def]
| DefPattern [Def]
| DefPackage PIdent [TopDef]
| DefVars [Def]
| DefTokenizer PIdent
deriving (Eq,Ord,Show)
data CatDef =
SimpleCatDef PIdent [DDecl]
| ListCatDef PIdent [DDecl]
| ListSizeCatDef PIdent [DDecl] Integer
deriving (Eq,Ord,Show)
data FunDef =
FunDef [PIdent] Exp
deriving (Eq,Ord,Show)
data DataDef =
DataDef PIdent [DataConstr]
deriving (Eq,Ord,Show)
data DataConstr =
DataId PIdent
| DataQId PIdent PIdent
deriving (Eq,Ord,Show)
data ParDef =
ParDefDir PIdent [ParConstr]
| ParDefIndir PIdent PIdent
| ParDefAbs PIdent
deriving (Eq,Ord,Show)
data ParConstr =
ParConstr PIdent [DDecl]
deriving (Eq,Ord,Show)
data PrintDef =
PrintDef [Name] Exp
deriving (Eq,Ord,Show)
data FlagDef =
FlagDef PIdent PIdent
deriving (Eq,Ord,Show)
data Name =
IdentName PIdent
| ListName PIdent
deriving (Eq,Ord,Show)
data LocDef =
LDDecl [PIdent] Exp
| LDDef [PIdent] Exp
| LDFull [PIdent] Exp Exp
deriving (Eq,Ord,Show)
data Exp =
EIdent PIdent
| EConstr PIdent
| ECons PIdent
| ESort Sort
| EString String
| EInt Integer
| EFloat Double
| EMeta
| EEmpty
| EData
| EList PIdent Exps
| EStrings String
| ERecord [LocDef]
| ETuple [TupleComp]
| EIndir PIdent
| ETyped Exp Exp
| EProj Exp Label
| EQConstr PIdent PIdent
| EQCons PIdent PIdent
| EApp Exp Exp
| ETable [Case]
| ETTable Exp [Case]
| EVTable Exp [Exp]
| ECase Exp [Case]
| EVariants [Exp]
| EPre Exp [Altern]
| EStrs [Exp]
| EConAt PIdent Exp
| EPatt Patt
| EPattType Exp
| ESelect Exp Exp
| ETupTyp Exp Exp
| EExtend Exp Exp
| EGlue Exp Exp
| EConcat Exp Exp
| EVariant Exp Exp
| EAbstr [Bind] Exp
| ECTable [Bind] Exp
| EProd Decl Exp
| ETType Exp Exp
| ELet [LocDef] Exp
| ELetb [LocDef] Exp
| EWhere Exp [LocDef]
| EEqs [Equation]
| EExample Exp String
| ELString LString
| ELin PIdent
deriving (Eq,Ord,Show)
data Exps =
NilExp
| ConsExp Exp Exps
deriving (Eq,Ord,Show)
data Patt =
PChar
| PChars String
| PMacro PIdent
| PM PIdent PIdent
| PW
| PV PIdent
| PCon PIdent
| PQ PIdent PIdent
| PInt Integer
| PFloat Double
| PStr String
| PR [PattAss]
| PTup [PattTupleComp]
| PC PIdent [Patt]
| PQC PIdent PIdent [Patt]
| PDisj Patt Patt
| PSeq Patt Patt
| PRep Patt
| PAs PIdent Patt
| PNeg Patt
deriving (Eq,Ord,Show)
data PattAss =
PA [PIdent] Patt
deriving (Eq,Ord,Show)
data Label =
LIdent PIdent
| LVar Integer
deriving (Eq,Ord,Show)
data Sort =
Sort_Type
| Sort_PType
| Sort_Tok
| Sort_Str
| Sort_Strs
deriving (Eq,Ord,Show)
data Bind =
BIdent PIdent
| BWild
deriving (Eq,Ord,Show)
data Decl =
DDec [Bind] Exp
| DExp Exp
deriving (Eq,Ord,Show)
data TupleComp =
TComp Exp
deriving (Eq,Ord,Show)
data PattTupleComp =
PTComp Patt
deriving (Eq,Ord,Show)
data Case =
Case Patt Exp
deriving (Eq,Ord,Show)
data Equation =
Equ [Patt] Exp
deriving (Eq,Ord,Show)
data Altern =
Alt Exp Exp
deriving (Eq,Ord,Show)
data DDecl =
DDDec [Bind] Exp
| DDExp Exp
deriving (Eq,Ord,Show)
data OldGrammar =
OldGr Include [TopDef]
deriving (Eq,Ord,Show)
data Include =
NoIncl
| Incl [FileName]
deriving (Eq,Ord,Show)
data FileName =
FString String
| FIdent PIdent
| FSlash FileName
| FDot FileName
| FMinus FileName
| FAddId PIdent FileName
deriving (Eq,Ord,Show)

372
src/GF/Source/GF.cf
View File

@@ -1,372 +0,0 @@
-- AR 2/5/2003, 14-16 o'clock, Torino
-- 17/6/2007: marked with suffix --% those lines that are obsolete and
-- should not be included in documentation
entrypoints Grammar, ModDef,
OldGrammar, --%
ModHeader,
Exp ; -- let's see if more are needed
comment "--" ;
comment "{-" "-}" ;
-- the top-level grammar
Gr. Grammar ::= [ModDef] ;
-- semicolon after module is permitted but not obligatory
terminator ModDef "" ;
_. ModDef ::= ModDef ";" ;
-- The $main$ multilingual grammar structure --%
MMain. ModDef ::= "grammar" PIdent "=" "{" "abstract" "=" PIdent ";" [ConcSpec] "}" ;--%
ConcSpec. ConcSpec ::= PIdent "=" ConcExp ;--%
separator ConcSpec ";" ;--%
ConcExp. ConcExp ::= PIdent [Transfer] ;--%
separator Transfer "" ;--%
TransferIn. Transfer ::= "(" "transfer" "in" Open ")" ; --%
TransferOut. Transfer ::= "(" "transfer" "out" Open ")" ; --%
-- the module header
MModule2. ModHeader ::= ComplMod ModType "=" ModHeaderBody ;
MBody2. ModHeaderBody ::= Extend Opens ;
MNoBody2. ModHeaderBody ::= [Included] ;
MWith2. ModHeaderBody ::= Included "with" [Open] ;
MWithBody2. ModHeaderBody ::= Included "with" [Open] "**" Opens ;
MWithE2. ModHeaderBody ::= [Included] "**" Included "with" [Open] ;
MWithEBody2. ModHeaderBody ::= [Included] "**" Included "with" [Open] "**" Opens ;
MReuse2. ModHeaderBody ::= "reuse" PIdent ; --%
MUnion2. ModHeaderBody ::= "union" [Included] ;--%
-- the individual modules
MModule. ModDef ::= ComplMod ModType "=" ModBody ;
MTAbstract. ModType ::= "abstract" PIdent ;
MTResource. ModType ::= "resource" PIdent ;
MTInterface. ModType ::= "interface" PIdent ;
MTConcrete. ModType ::= "concrete" PIdent "of" PIdent ;
MTInstance. ModType ::= "instance" PIdent "of" PIdent ;
MTTransfer. ModType ::= "transfer" PIdent ":" Open "->" Open ;
MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ;
MNoBody. ModBody ::= [Included] ;
MWith. ModBody ::= Included "with" [Open] ;
MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MWithE. ModBody ::= [Included] "**" Included "with" [Open] ;
MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MReuse. ModBody ::= "reuse" PIdent ; --%
MUnion. ModBody ::= "union" [Included] ;--%
separator TopDef "" ;
Ext. Extend ::= [Included] "**" ;
NoExt. Extend ::= ;
separator Open "," ;
NoOpens. Opens ::= ;
OpenIn. Opens ::= "open" [Open] "in" ;
OName. Open ::= PIdent ;
OQualQO. Open ::= "(" QualOpen PIdent ")" ;
OQual. Open ::= "(" QualOpen PIdent "=" PIdent ")" ;
CMCompl. ComplMod ::= ;
CMIncompl. ComplMod ::= "incomplete" ;
QOCompl. QualOpen ::= ;
QOIncompl. QualOpen ::= "incomplete" ;--%
QOInterface. QualOpen ::= "interface" ;--%
separator Included "," ;
IAll. Included ::= PIdent ;
ISome. Included ::= PIdent "[" [PIdent] "]" ;
IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ;
-- definitions after the $oper$ keywords
DDecl. Def ::= [Name] ":" Exp ;
DDef. Def ::= [Name] "=" Exp ;
DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list
DFull. Def ::= [Name] ":" Exp "=" Exp ;
-- top-level definitions
DefCat. TopDef ::= "cat" [CatDef] ;
DefFun. TopDef ::= "fun" [FunDef] ;
DefFunData.TopDef ::= "data" [FunDef] ;
DefDef. TopDef ::= "def" [Def] ;
DefData. TopDef ::= "data" [DataDef] ;
DefTrans. TopDef ::= "transfer" [Def] ;--%
DefPar. TopDef ::= "param" [ParDef] ;
DefOper. TopDef ::= "oper" [Def] ;
DefLincat. TopDef ::= "lincat" [PrintDef] ;
DefLindef. TopDef ::= "lindef" [Def] ;
DefLin. TopDef ::= "lin" [Def] ;
DefPrintCat. TopDef ::= "printname" "cat" [PrintDef] ;
DefPrintFun. TopDef ::= "printname" "fun" [PrintDef] ;
DefFlag. TopDef ::= "flags" [FlagDef] ;
SimpleCatDef. CatDef ::= PIdent [DDecl] ;
ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ;
ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ;
FunDef. FunDef ::= [PIdent] ":" Exp ;
DataDef. DataDef ::= PIdent "=" [DataConstr] ;
DataId. DataConstr ::= PIdent ;
DataQId. DataConstr ::= PIdent "." PIdent ;
separator DataConstr "|" ;
ParDefDir. ParDef ::= PIdent "=" [ParConstr] ;
ParDefIndir. ParDef ::= PIdent "=" "(" "in" PIdent ")" ;
ParDefAbs. ParDef ::= PIdent ;
ParConstr. ParConstr ::= PIdent [DDecl] ;
PrintDef. PrintDef ::= [Name] "=" Exp ;
FlagDef. FlagDef ::= PIdent "=" PIdent ;
terminator nonempty Def ";" ;
terminator nonempty CatDef ";" ;
terminator nonempty FunDef ";" ;
terminator nonempty DataDef ";" ;
terminator nonempty ParDef ";" ;
terminator nonempty PrintDef ";" ;
terminator nonempty FlagDef ";" ;
separator ParConstr "|" ;
separator nonempty PIdent "," ;
-- names of categories and functions in definition LHS
IdentName. Name ::= PIdent ;
ListName. Name ::= "[" PIdent "]" ;
separator nonempty Name "," ;
-- definitions in records and $let$ expressions
LDDecl. LocDef ::= [PIdent] ":" Exp ;
LDDef. LocDef ::= [PIdent] "=" Exp ;
LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ;
separator LocDef ";" ;
-- terms and types
EIdent. Exp6 ::= PIdent ;
EConstr. Exp6 ::= "{" PIdent "}" ;--%
ECons. Exp6 ::= "%" PIdent "%" ;--%
ESort. Exp6 ::= Sort ;
EString. Exp6 ::= String ;
EInt. Exp6 ::= Integer ;
EFloat. Exp6 ::= Double ;
EMeta. Exp6 ::= "?" ;
EEmpty. Exp6 ::= "[" "]" ;
EData. Exp6 ::= "data" ;
EList. Exp6 ::= "[" PIdent Exps "]" ;
EStrings. Exp6 ::= "[" String "]" ;
ERecord. Exp6 ::= "{" [LocDef] "}" ; -- !
ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator ","
EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --%
ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations
EProj. Exp5 ::= Exp5 "." Label ;
EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --%
EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --%
EApp. Exp4 ::= Exp4 Exp5 ;
ETable. Exp4 ::= "table" "{" [Case] "}" ;
ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ;
EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
--- EPreCase. Exp4 ::= "pre" "{" [Case] "}" ;
EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
EStrs. Exp4 ::= "strs" "{" [Exp] "}" ;
EConAt. Exp4 ::= PIdent "@" Exp6 ; --%
EPatt. Exp4 ::= "#" Patt2 ;
EPattType. Exp4 ::= "pattern" Exp5 ;
ESelect. Exp3 ::= Exp3 "!" Exp4 ;
ETupTyp. Exp3 ::= Exp3 "*" Exp4 ;
EExtend. Exp3 ::= Exp3 "**" Exp4 ;
EGlue. Exp2 ::= Exp3 "+" Exp2 ;
EConcat. Exp1 ::= Exp2 "++" Exp1 ;
EVariant. Exp ::= Exp1 "|" Exp ;
EAbstr. Exp ::= "\\" [Bind] "->" Exp ;
ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ;
EProd. Exp ::= Decl "->" Exp ;
ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative
ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ;
ELetb. Exp ::= "let" [LocDef] "in" Exp ;
EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ;
EEqs. Exp ::= "fn" "{" [Equation] "}" ; --%
EExample. Exp ::= "in" Exp5 String ;
coercions Exp 6 ;
separator Exp ";" ; -- in variants
-- list of arguments to category
NilExp. Exps ::= ;
ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses
-- patterns
PChar. Patt2 ::= "?" ;
PChars. Patt2 ::= "[" String "]" ;
PMacro. Patt2 ::= "#" PIdent ;
PM. Patt2 ::= "#" PIdent "." PIdent ;
PW. Patt2 ::= "_" ;
PV. Patt2 ::= PIdent ;
PCon. Patt2 ::= "{" PIdent "}" ; --%
PQ. Patt2 ::= PIdent "." PIdent ;
PInt. Patt2 ::= Integer ;
PFloat. Patt2 ::= Double ;
PStr. Patt2 ::= String ;
PR. Patt2 ::= "{" [PattAss] "}" ;
PTup. Patt2 ::= "<" [PattTupleComp] ">" ;
PC. Patt1 ::= PIdent [Patt] ;
PQC. Patt1 ::= PIdent "." PIdent [Patt] ;
PDisj. Patt ::= Patt "|" Patt1 ;
PSeq. Patt ::= Patt "+" Patt1 ;
PRep. Patt1 ::= Patt2 "*" ;
PAs. Patt1 ::= PIdent "@" Patt2 ;
PNeg. Patt1 ::= "-" Patt2 ;
coercions Patt 2 ;
PA. PattAss ::= [PIdent] "=" Patt ;
-- labels
LIdent. Label ::= PIdent ;
LVar. Label ::= "$" Integer ;
-- basic types
rules Sort ::=
"Type"
| "PType"
| "Tok" --%
| "Str"
| "Strs" ;
separator PattAss ";" ;
-- this is explicit to force higher precedence level on rhs
(:[]). [Patt] ::= Patt2 ;
(:). [Patt] ::= Patt2 [Patt] ;
-- binds in lambdas and lin rules
BIdent. Bind ::= PIdent ;
BWild. Bind ::= "_" ;
separator Bind "," ;
-- declarations in function types
DDec. Decl ::= "(" [Bind] ":" Exp ")" ;
DExp. Decl ::= Exp4 ; -- can thus be an application
-- tuple component (term or pattern)
TComp. TupleComp ::= Exp ;
PTComp. PattTupleComp ::= Patt ;
separator TupleComp "," ;
separator PattTupleComp "," ;
-- case branches
Case. Case ::= Patt "=>" Exp ;
separator nonempty Case ";" ;
-- cases in abstract syntax --%
Equ. Equation ::= [Patt] "->" Exp ; --%
separator Equation ";" ; --%
-- prefix alternatives
Alt. Altern ::= Exp "/" Exp ;
separator Altern ";" ;
-- in a context, higher precedence is required than in function types
DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ;
DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application
separator DDecl "" ;
-------------------------------------- --%
-- for backward compatibility --%
OldGr. OldGrammar ::= Include [TopDef] ; --%
NoIncl. Include ::= ; --%
Incl. Include ::= "include" [FileName] ; --%
FString. FileName ::= String ; --%
terminator nonempty FileName ";" ; --%
FIdent. FileName ::= PIdent ; --%
FSlash. FileName ::= "/" FileName ; --%
FDot. FileName ::= "." FileName ; --%
FMinus. FileName ::= "-" FileName ; --%
FAddId. FileName ::= PIdent FileName ; --%
token LString '\'' (char - '\'')* '\'' ; --%
ELString. Exp6 ::= LString ; --%
ELin. Exp4 ::= "Lin" PIdent ; --%
DefPrintOld. TopDef ::= "printname" [PrintDef] ; --%
DefLintype. TopDef ::= "lintype" [Def] ; --%
DefPattern. TopDef ::= "pattern" [Def] ; --%
-- deprecated packages are attempted to be interpreted --%
DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --%
-- these two are just ignored after parsing --%
DefVars. TopDef ::= "var" [Def] ; --%
DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --%
-- identifiers
position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ;

233
src/GF/Source/GrammarToSource.hs
View File

@@ -1,233 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GrammarToSource
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/04 11:05:07 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.23 $
--
-- From internal source syntax to BNFC-generated (used for printing).
-----------------------------------------------------------------------------
module GF.Source.GrammarToSource ( trGrammar,
trModule,
trAnyDef,
trLabel,
trt, tri, trp
) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Grammar.Predef
import GF.Infra.Modules
import GF.Infra.Option
import qualified GF.Source.AbsGF as P
import GF.Infra.Ident
import qualified Data.ByteString.Char8 as BS
-- | AR 13\/5\/2003
--
-- translate internal to parsable and printable source
trGrammar :: SourceGrammar -> P.Grammar
trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
trModule :: (Ident,SourceModInfo) -> P.ModDef
trModule (i,m) = P.MModule compl typ body
where
compl = case mstatus m of
MSIncomplete -> P.CMIncompl
_ -> P.CMCompl
i' = tri i
typ = case mtype m of
MTResource -> P.MTResource i'
MTAbstract -> P.MTAbstract i'
MTConcrete a -> P.MTConcrete i' (tri a)
MTTransfer a b -> P.MTTransfer i' (trOpen a) (trOpen b)
MTInstance a -> P.MTInstance i' (tri a)
MTInterface -> P.MTInterface i'
body = P.MBody
(trExtends (extend m))
(mkOpens (map trOpen (opens m)))
(mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ trFlags (flags m)))
trExtends :: [(Ident,MInclude Ident)] -> P.Extend
trExtends [] = P.NoExt
trExtends es = (P.Ext $ map tre es) where
tre (i,c) = case c of
MIAll -> P.IAll (tri i)
MIOnly is -> P.ISome (tri i) (map tri is)
MIExcept is -> P.IMinus (tri i) (map tri is)
---- this has to be completed with other mtys
forName (MTConcrete a) = tri a
trOpen :: OpenSpec Ident -> P.Open
trOpen o = case o of
OSimple i -> P.OName (tri i)
OQualif i j -> P.OQual P.QOCompl (tri i) (tri j)
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
mkTopDefs ds = ds
trAnyDef :: (Ident,Info) -> [P.TopDef]
trAnyDef (i,info) = let i' = tri i in case info of
AbsCat (Just co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]]
AbsFun (Just ty) _ Nothing -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
AbsFun (Just ty) _ (Just eqs) -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++
[P.DefDef [P.DPatt (mkName i') (map trp patts) (trt res)] | (patts,res) <- eqs]
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of
Just (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
Nothing -> P.ParDefAbs i']]
ResOverload os tysts ->
[P.DefOper [P.DDef [mkName i'] (
foldl P.EApp
(P.EIdent $ tri $ cOverload)
(map (P.EIdent . tri) os ++
[P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]]))]]
CncCat (Just ty) Nothing _ ->
[P.DefLincat [P.PrintDef [mkName i'] (trt ty)]]
CncCat pty ptr ppr ->
[P.DefLindef [trDef i' pty ptr]] ++
[P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Just pr <- [ppr]]
CncFun _ ptr ppr ->
[P.DefLin [trDef i' Nothing ptr]] ++
[P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Just pr <- [ppr]]
_ -> []
trDef :: P.PIdent -> Maybe Type -> Maybe Term -> P.Def
trDef i pty ptr = case (pty,ptr) of
(Nothing, Nothing) -> P.DDef [mkName i] (P.EMeta) ---
(_, Nothing) -> P.DDecl [mkName i] (maybe P.EMeta trt pty)
(Nothing, _ ) -> P.DDef [mkName i] (maybe P.EMeta trt ptr)
(_, _ ) -> P.DFull [mkName i] (maybe P.EMeta trt pty) (maybe P.EMeta trt ptr)
trFlags :: Options -> [P.TopDef]
trFlags = map trFlag . optionsGFO
trFlag :: (String,String) -> P.TopDef
trFlag (f,x) = P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
trt :: Term -> P.Exp
trt trm = case trm of
Vr s -> P.EIdent $ tri s
Cn s -> P.ECons $ tri s
Con s -> P.EConstr $ tri s
Sort s -> P.ESort $! if s == cType then P.Sort_Type else
if s == cPType then P.Sort_PType else
if s == cTok then P.Sort_Tok else
if s == cStr then P.Sort_Str else
if s == cStrs then P.Sort_Strs else
error $ "not yet sort " +++ show trm
App c a -> P.EApp (trt c) (trt a)
Abs x b -> P.EAbstr [trb x] (trt b)
Meta m -> P.EMeta
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
Example t s -> P.EExample (trt t) s
R [] -> P.ETuple [] --- to get correct parsing when read back
R r -> P.ERecord $ map trAssign r
RecType r -> P.ERecord $ map trLabelling r
ExtR x y -> P.EExtend (trt x) (trt y)
P t l -> P.EProj (trt t) (trLabel l)
PI t l _ -> P.EProj (trt t) (trLabel l)
Q t l -> P.EQCons (tri t) (tri l)
QC t l -> P.EQConstr (tri t) (tri l)
TSh (TComp ty) cc -> P.ETTable (trt ty) (map trCases cc)
TSh (TTyped ty) cc -> P.ETTable (trt ty) (map trCases cc)
TSh (TWild ty) cc -> P.ETTable (trt ty) (map trCases cc)
T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
T _ cc -> P.ETable (map trCase cc)
V ty cc -> P.EVTable (trt ty) (map trt cc)
Table x v -> P.ETType (trt x) (trt v)
S f x -> P.ESelect (trt f) (trt x)
---- Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t
-- Alias c a t -> prt (Let (c,(Just a,t)) (Vr c)) -- thus Alias is only internal
Let (x,(ma,b)) t ->
P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t)
where
b' = trt b
x' = [tri x]
Empty -> P.EEmpty
K [] -> P.EEmpty
K a -> P.EString a
C a b -> P.EConcat (trt a) (trt b)
EInt i -> P.EInt i
EFloat i -> P.EFloat i
EPatt p -> P.EPatt (trp p)
EPattType t -> P.EPattType (trt t)
Glue a b -> P.EGlue (trt a) (trt b)
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
FV ts -> P.EVariants $ map trt ts
Strs tt -> P.EStrs $ map trt tt
Val te _ _ -> trt te ----
_ -> error $ "not yet" +++ show trm ----
trp :: Patt -> P.Patt
trp p = case p of
PW -> P.PW
PV s -> P.PV $ tri s
PC c [] -> P.PCon $ tri c
PC c a -> P.PC (tri c) (map trp a)
PP p c [] -> P.PQ (tri p) (tri c)
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
PR r -> P.PR [P.PA [tri $ label2ident l] (trp p) | (l,p) <- r]
PString s -> P.PStr s
PInt i -> P.PInt i
PFloat i -> P.PFloat i
PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
PAs x p -> P.PAs (tri x) (trp p)
PAlt p q -> P.PDisj (trp p) (trp q)
PSeq p q -> P.PSeq (trp p) (trp q)
PRep p -> P.PRep (trp p)
PNeg p -> P.PNeg (trp p)
PChar -> P.PChar
PChars s -> P.PChars s
PM m c -> P.PM (tri m) (tri c)
PVal p _ _ -> trp p ----
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
where
t' = trt t
x = [tri $ label2ident lab]
trLabelling (lab,ty) = P.LDDecl [tri $ label2ident lab] (trt ty)
trCase (patt, trm) = P.Case (trp patt) (trt trm)
trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
tri :: Ident -> P.PIdent
tri = ppIdent . ident2bs
ppIdent i = P.PIdent ((0,0),i)
trb i = if isWildIdent i then P.BWild else P.BIdent (tri i)
trLabel :: Label -> P.Label
trLabel i = case i of
LIdent s -> P.LIdent $ ppIdent s
LVar i -> P.LVar $ toInteger i
mkName :: P.PIdent -> P.Name
mkName = P.IdentName

7
src/GF/Source/Makefile
View File

@@ -1,7 +0,0 @@
all:
cd ../.. && bnfc -p GF.Source -bytestrings GF/Source/GF.cf
rm ErrM.hs
perl -i -pe 's/%name pModHeader ModHeader/%partial pModHeader ModHeader/' ParGF.y
perl -i -pe 's/GF.Source.ErrM/GF.Data.ErrM/' *.hs *.x *.y
happy -gca ParGF.y
alex -g LexGF.x

551
src/GF/Source/PrintGF.hs
View File

@@ -1,551 +0,0 @@
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.Source.PrintGF where
-- pretty-printer generated by the BNF converter
import GF.Source.AbsGF
import Data.Char
import qualified Data.ByteString.Char8 as BS
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
prtList :: [a] -> Doc
prtList = concatD . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = doc (shows x)
instance Print Double where
prt _ x = doc (shows x)
instance Print LString where
prt _ (LString i) = doc (showString (BS.unpack i))
instance Print PIdent where
prt _ (PIdent (_,i)) = doc (showString (BS.unpack i))
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Grammar where
prt i e = case e of
Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs])
instance Print ModDef where
prt i e = case e of
MMain pident0 pident concspecs -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident0 , doc (showString "=") , doc (showString "{") , doc (showString "abstract") , doc (showString "=") , prt 0 pident , doc (showString ";") , prt 0 concspecs , doc (showString "}")])
MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print ConcSpec where
prt i e = case e of
ConcSpec pident concexp -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 concexp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print ConcExp where
prt i e = case e of
ConcExp pident transfers -> prPrec i 0 (concatD [prt 0 pident , prt 0 transfers])
instance Print Transfer where
prt i e = case e of
TransferIn open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "in") , prt 0 open , doc (showString ")")])
TransferOut open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "out") , prt 0 open , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print ModHeader where
prt i e = case e of
MModule2 complmod modtype modheaderbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modheaderbody])
instance Print ModHeaderBody where
prt i e = case e of
MBody2 extend opens -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens])
MNoBody2 includeds -> prPrec i 0 (concatD [prt 0 includeds])
MWith2 included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens])
MWithBody2 included opens0 opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens])
MWithE2 includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens])
MWithEBody2 includeds included opens0 opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens])
MReuse2 pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident])
MUnion2 includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds])
instance Print ModType where
prt i e = case e of
MTAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident])
MTResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident])
MTInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident])
MTConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
MTInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
MTTransfer pident open0 open -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 pident , doc (showString ":") , prt 0 open0 , doc (showString "->") , prt 0 open])
instance Print ModBody where
prt i e = case e of
MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds])
MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens])
MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens])
MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident])
MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds])
instance Print Extend where
prt i e = case e of
Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")])
NoExt -> prPrec i 0 (concatD [])
instance Print Opens where
prt i e = case e of
NoOpens -> prPrec i 0 (concatD [])
OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")])
instance Print Open where
prt i e = case e of
OName pident -> prPrec i 0 (concatD [prt 0 pident])
OQualQO qualopen pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident , doc (showString ")")])
OQual qualopen pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print ComplMod where
prt i e = case e of
CMCompl -> prPrec i 0 (concatD [])
CMIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")])
instance Print QualOpen where
prt i e = case e of
QOCompl -> prPrec i 0 (concatD [])
QOIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")])
QOInterface -> prPrec i 0 (concatD [doc (showString "interface")])
instance Print Included where
prt i e = case e of
IAll pident -> prPrec i 0 (concatD [prt 0 pident])
ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")])
IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Def where
prt i e = case e of
DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp])
DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp])
DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print TopDef where
prt i e = case e of
DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs])
DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs])
DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs])
DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs])
DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs])
DefTrans defs -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 defs])
DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs])
DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs])
DefLincat printdefs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 printdefs])
DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs])
DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs])
DefPrintCat printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 printdefs])
DefPrintFun printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 printdefs])
DefFlag flagdefs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 flagdefs])
DefPrintOld printdefs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 printdefs])
DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs])
DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs])
DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")])
DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs])
DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print CatDef where
prt i e = case e of
SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")])
ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print FunDef where
prt i e = case e of
FunDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print DataDef where
prt i e = case e of
DataDef pident dataconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 dataconstrs])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print DataConstr where
prt i e = case e of
DataId pident -> prPrec i 0 (concatD [prt 0 pident])
DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
instance Print ParDef where
prt i e = case e of
ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs])
ParDefIndir pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")])
ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print ParConstr where
prt i e = case e of
ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
instance Print PrintDef where
prt i e = case e of
PrintDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print FlagDef where
prt i e = case e of
FlagDef pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , prt 0 pident])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Name where
prt i e = case e of
IdentName pident -> prPrec i 0 (concatD [prt 0 pident])
ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print LocDef where
prt i e = case e of
LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp])
LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp])
LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Exp where
prt i e = case e of
EIdent pident -> prPrec i 6 (concatD [prt 0 pident])
EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")])
ESort sort -> prPrec i 6 (concatD [prt 0 sort])
EString str -> prPrec i 6 (concatD [prt 0 str])
EInt n -> prPrec i 6 (concatD [prt 0 n])
EFloat d -> prPrec i 6 (concatD [prt 0 d])
EMeta -> prPrec i 6 (concatD [doc (showString "?")])
EEmpty -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")])
EData -> prPrec i 6 (concatD [doc (showString "data")])
EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")])
EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")])
ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")])
EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")])
ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")])
EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label])
EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")])
EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp])
ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])
EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")])
EConAt pident exp -> prPrec i 4 (concatD [prt 0 pident , doc (showString "@") , prt 6 exp])
EPatt patt -> prPrec i 4 (concatD [doc (showString "#") , prt 2 patt])
EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , prt 5 exp])
ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp])
ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp])
EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp])
EGlue exp0 exp -> prPrec i 2 (concatD [prt 3 exp0 , doc (showString "+") , prt 2 exp])
EConcat exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "++") , prt 1 exp])
EVariant exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "|") , prt 0 exp])
EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp])
ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp])
EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp])
ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp])
ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp])
EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")])
EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")])
EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str])
ELString lstring -> prPrec i 6 (concatD [prt 0 lstring])
ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Exps where
prt i e = case e of
NilExp -> prPrec i 0 (concatD [])
ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps])
instance Print Patt where
prt i e = case e of
PChar -> prPrec i 2 (concatD [doc (showString "?")])
PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident])
PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
PW -> prPrec i 2 (concatD [doc (showString "_")])
PV pident -> prPrec i 2 (concatD [prt 0 pident])
PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
PInt n -> prPrec i 2 (concatD [prt 0 n])
PFloat d -> prPrec i 2 (concatD [prt 0 d])
PStr str -> prPrec i 2 (concatD [prt 0 str])
PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")])
PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")])
PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts])
PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts])
PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt])
PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt])
PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")])
PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt])
PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt])
prtList es = case es of
[x] -> (concatD [prt 2 x])
x:xs -> (concatD [prt 2 x , prt 0 xs])
instance Print PattAss where
prt i e = case e of
PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 patt])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Label where
prt i e = case e of
LIdent pident -> prPrec i 0 (concatD [prt 0 pident])
LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
instance Print Sort where
prt i e = case e of
Sort_Type -> prPrec i 0 (concatD [doc (showString "Type")])
Sort_PType -> prPrec i 0 (concatD [doc (showString "PType")])
Sort_Tok -> prPrec i 0 (concatD [doc (showString "Tok")])
Sort_Str -> prPrec i 0 (concatD [doc (showString "Str")])
Sort_Strs -> prPrec i 0 (concatD [doc (showString "Strs")])
instance Print Bind where
prt i e = case e of
BIdent pident -> prPrec i 0 (concatD [prt 0 pident])
BWild -> prPrec i 0 (concatD [doc (showString "_")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Decl where
prt i e = case e of
DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
DExp exp -> prPrec i 0 (concatD [prt 4 exp])
instance Print TupleComp where
prt i e = case e of
TComp exp -> prPrec i 0 (concatD [prt 0 exp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print PattTupleComp where
prt i e = case e of
PTComp patt -> prPrec i 0 (concatD [prt 0 patt])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Case where
prt i e = case e of
Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Equation where
prt i e = case e of
Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , doc (showString "->") , prt 0 exp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Altern where
prt i e = case e of
Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/") , prt 0 exp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print DDecl where
prt i e = case e of
DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
DDExp exp -> prPrec i 0 (concatD [prt 6 exp])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print OldGrammar where
prt i e = case e of
OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs])
instance Print Include where
prt i e = case e of
NoIncl -> prPrec i 0 (concatD [])
Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames])
instance Print FileName where
prt i e = case e of
FString str -> prPrec i 0 (concatD [prt 0 str])
FIdent pident -> prPrec i 0 (concatD [prt 0 pident])
FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename])
FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename])
FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename])
FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])

733
src/GF/Source/SourceToGrammar.hs
View File

@@ -1,733 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : SourceToGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/04 11:05:07 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.28 $
--
-- based on the skeleton Haskell module generated by the BNF converter
-----------------------------------------------------------------------------
module GF.Source.SourceToGrammar ( transGrammar,
transInclude,
transModDef,
transOldGrammar,
transExp,
newReservedWords
) where
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.PrGrammar as GP
import qualified GF.Infra.Modules as GM
import qualified GF.Grammar.Macros as M
import qualified GF.Compile.Update as U
import qualified GF.Infra.Option as GO
import qualified GF.Compile.ModDeps as GD
import GF.Grammar.Predef
import GF.Infra.Ident
import GF.Source.AbsGF
import GF.Source.PrintGF
import GF.Data.Operations
import GF.Infra.Option
import Control.Monad
import Data.Char
import Data.List (genericReplicate)
import qualified Data.ByteString.Char8 as BS
-- based on the skeleton Haskell module generated by the BNF converter
type Result = Err String
failure :: Show a => a -> Err b
failure x = Bad $ "Undefined case: " ++ show x
getIdentPos :: PIdent -> Err (Ident,Int)
getIdentPos x = case x of
PIdent ((line,_),c) -> return (IC c,line)
transIdent :: PIdent -> Err Ident
transIdent = liftM fst . getIdentPos
transName :: Name -> Err Ident
transName n = case n of
IdentName i -> transIdent i
ListName i -> liftM mkListId (transIdent i)
transNamePos :: Name -> Err (Ident,Int)
transNamePos n = case n of
IdentName i -> getIdentPos i
ListName i -> liftM (\ (c,p) -> (mkListId c,p)) (getIdentPos i)
transGrammar :: Grammar -> Err G.SourceGrammar
transGrammar x = case x of
Gr moddefs -> do
moddefs' <- mapM transModDef moddefs
GD.mkSourceGrammar moddefs'
transModDef :: ModDef -> Err G.SourceModule
transModDef x = case x of
MModule compl mtyp body -> do
let mstat' = transComplMod compl
(trDef, mtyp', id') <- case mtyp of
MTAbstract id -> do
id' <- transIdent id
return (transAbsDef, GM.MTAbstract, id')
MTResource id -> mkModRes id GM.MTResource body
MTConcrete id open -> do
id' <- transIdent id
open' <- transIdent open
return (transCncDef, GM.MTConcrete open', id')
MTTransfer id a b -> do
id' <- transIdent id
a' <- transOpen a
b' <- transOpen a
return (transAbsDef, GM.MTTransfer a' b', id')
MTInterface id -> mkModRes id GM.MTInterface body
MTInstance id open -> do
open' <- transIdent open
mkModRes id (GM.MTInstance open') body
mkBody (mstat', trDef, mtyp', id') body
where
poss = emptyBinTree ----
mkBody xx@(mstat', trDef, mtyp', id') bod = case bod of
MNoBody incls -> do
mkBody xx $ MBody (Ext incls) NoOpens []
MBody extends opens defs -> do
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1)
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens []
MWithEBody extends m insts opens defs -> do
extends' <- mapM transIncludedExt extends
m' <- transIncludedExt m
insts' <- mapM transInst insts
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1)
mkModRes id mtyp body = do
id' <- transIdent id
return (transResDef, mtyp, id')
transComplMod :: ComplMod -> GM.ModuleStatus
transComplMod x = case x of
CMCompl -> GM.MSComplete
CMIncompl -> GM.MSIncomplete
getTopDefs :: [TopDef] -> [TopDef]
getTopDefs x = x
transConcExp :: ConcExp ->
Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident))
transConcExp x = case x of
ConcExp id transfers -> do
id' <- transIdent id
trs <- mapM transTransfer transfers
tin <- case [o | Left o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer in"
tout <- case [o | Right o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer out"
return (id',tin,tout)
transTransfer :: Transfer ->
Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident))
transTransfer x = case x of
TransferIn open -> liftM Left $ transOpen open
TransferOut open -> liftM Right $ transOpen open
transExtend :: Extend -> Err [(Ident,GM.MInclude Ident)]
transExtend x = case x of
Ext ids -> mapM transIncludedExt ids
NoExt -> return []
transOpens :: Opens -> Err [GM.OpenSpec Ident]
transOpens x = case x of
NoOpens -> return []
OpenIn opens -> mapM transOpen opens
transOpen :: Open -> Err (GM.OpenSpec Ident)
transOpen x = case x of
OName id -> liftM GM.OSimple (transIdent id)
OQualQO q id -> liftM GM.OSimple (transIdent id)
OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
transInst :: Open -> Err (Ident,Ident)
transInst x = case x of
OQual q id m -> liftM2 (,) (transIdent id) (transIdent m)
_ -> Bad "qualified open expected"
transIncluded :: Included -> Err (Ident,[Ident])
transIncluded x = case x of
IAll i -> liftM (flip (curry id) []) $ transIdent i
ISome i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids)
IMinus i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) ----
transIncludedExt :: Included -> Err (Ident, GM.MInclude Ident)
transIncludedExt x = case x of
IAll i -> liftM2 (,) (transIdent i) (return GM.MIAll)
ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids)
IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
--- where no position is saved
nopos :: Int
nopos = -1
buildPosTree :: Ident -> [(Ident,Int)] -> BinTree Ident (String,(Int,Int))
buildPosTree m = buildTree . mkPoss . filter ((>0) . snd) where
mkPoss cs = case cs of
(i,p):rest@((_,q):_) -> (i,(name,(p,max p (q-1)))) : mkPoss rest
(i,p):[] -> (i,(name,(p,p+100))) : [] --- don't know last line
_ -> []
name = showIdent m ++ ".gf" ----
transAbsDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options)
transAbsDef x = case x of
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
DefFun fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl [(fun, nopos, G.AbsFun (Just typ) Nothing) | (funs,typ) <- fundefs', fun <- funs]
DefFunData fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl $
[(cat, nopos, G.AbsCat Nothing (Just [G.Cn fun])) | (funs,typ) <- fundefs',
fun <- funs,
Ok (_,cat) <- [M.valCat typ]
] ++
[(fun, nopos, G.AbsFun (Just typ) (Just G.EData)) | (funs,typ) <- fundefs', fun <- funs]
DefDef defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, nopos, G.AbsFun Nothing pe) | ((c,p),(_,pe)) <- defs']
DefData ds -> do
ds' <- mapM transDataDef ds
returnl $
[(c, nopos, G.AbsCat Nothing (Just ps)) | (c,ps) <- ds'] ++
[(f, nopos, G.AbsFun Nothing (Just G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where
-- to get data constructors as terms
funs t = case t of
G.Cn f -> [f]
G.Q _ f -> [f]
G.QC _ f -> [f]
_ -> []
returnl :: a -> Err (Either a b)
returnl = return . Left
transFlagDef :: FlagDef -> Err GO.Options
transFlagDef x = case x of
FlagDef f x -> parseModuleOptions ["--" ++ prPIdent f ++ "=" ++ prPIdent x]
where
prPIdent (PIdent (_,c)) = BS.unpack c
-- | Cat definitions can also return some fun defs
-- if it is a list category definition
transCatDef :: CatDef -> Err [(Ident, Int, G.Info)]
transCatDef x = case x of
SimpleCatDef id ddecls -> do
(id',pos) <- getIdentPos id
liftM (:[]) $ cat id' pos ddecls
ListCatDef id ddecls -> listCat id ddecls 0
ListSizeCatDef id ddecls size -> listCat id ddecls size
where
cat i pos ddecls = do
-- i <- transIdent id
cont <- liftM concat $ mapM transDDecl ddecls
return (i, pos, G.AbsCat (Just cont) Nothing)
listCat id ddecls size = do
(id',pos) <- getIdentPos id
let
li = mkListId id'
baseId = mkBaseId id'
consId = mkConsId id'
catd0@(c,p,G.AbsCat (Just cont0) _) <- cat li pos ddecls
let
catd = (c,pos,G.AbsCat (Just cont0) (Just [G.Cn baseId,G.Cn consId]))
cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
xs = map (G.Vr . fst) cont
cd = M.mkDecl (M.mkApp (G.Vr id') xs)
lc = M.mkApp (G.Vr li) xs
niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc
nilfund = (baseId, nopos, G.AbsFun (Just niltyp) (Just G.EData))
constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, nopos, G.AbsFun (Just constyp) (Just G.EData))
return [catd,nilfund,consfund]
mkId x i = if isWildIdent x then (varX i) else x
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of
FunDef ids typ -> liftM2 (,) (mapM transIdent ids) (transExp typ)
transDataDef :: DataDef -> Err (Ident,[G.Term])
transDataDef x = case x of
DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds)
where
transData d = case d of
DataId id -> liftM G.Cn $ transIdent id
DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id)
transResDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options)
transResDef x = case x of
DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs
returnl $ [(p, nopos, G.ResParam (if null pars
then Nothing -- abstract param type
else (Just (pars,Nothing))))
| (p,pars) <- pardefs']
++ [(f, nopos, G.ResValue (Just (M.mkProdSimple co (G.Cn p),Nothing))) |
(p,pars) <- pardefs', (f,co) <- pars]
DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl $
concatMap mkOverload [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefLintype defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition form in resource" +++ printTree x
where
mkOverload op@(c,p,j) = case j of
G.ResOper _ (Just df) -> case M.appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
G.R fs ->
[(c,p,G.ResOverload [m | G.Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs])]
_ -> [op]
_ -> [op]
-- to enable separare type signature --- not type-checked
G.ResOper (Just df) _ -> case M.appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
G.RecType _ -> []
_ -> [op]
_ -> [op]
_ -> [(c,p,j)]
isOverloading keyw =
GP.prt keyw == "overload" -- overload is a "soft keyword"
isRec t = case t of
G.R _ -> True
_ -> False
transParDef :: ParDef -> Err (Ident, [G.Param])
transParDef x = case x of
ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
_ -> Bad $ "illegal definition in resource:" ++++ printTree x
transCncDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options)
transCncDef x = case x of
DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncCat (Just t) Nothing Nothing) | (f,t) <- defs']
DefLindef defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.CncCat pt pe Nothing) | ((f,p),(pt,pe)) <- defs']
DefLin defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.CncFun Nothing pe Nothing) | ((f,p),(_,pe)) <- defs']
DefPrintCat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncCat Nothing Nothing (Just e)) | (f,e) <- defs']
DefPrintFun defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs']
DefPrintOld defs -> do --- a guess, for backward compatibility
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs']
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
DefPattern defs -> do
defs' <- liftM concat $ mapM getDefs defs
let defs2 = [(f, termInPattern t) | (f,(_,Just t)) <- defs']
returnl [(f, p, G.CncFun Nothing (Just t) Nothing) | ((f,p),t) <- defs2]
_ -> errIn ("illegal definition in concrete syntax:") $ transResDef x
transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
transPrintDef x = case x of
PrintDef ids exp -> do
(ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
return $ [(i,e) | i <- ids]
getDefsGen :: Def -> Err [((Ident, Int),(Maybe G.Type, Maybe G.Term))]
getDefsGen d = case d of
DDecl ids t -> do
ids' <- mapM transNamePos ids
t' <- transExp t
return [(i,(Just t', Nothing)) | i <- ids']
DDef ids e -> do
ids' <- mapM transNamePos ids
e' <- transExp e
return [(i,(Nothing, Just e')) | i <- ids']
DFull ids t e -> do
ids' <- mapM transNamePos ids
t' <- transExp t
e' <- transExp e
return [(i,(Just t', Just e')) | i <- ids']
DPatt id patts e -> do
id' <- transNamePos id
ps' <- mapM transPatt patts
e' <- transExp e
return [(id',(Nothing, Just (G.Eqs [(ps',e')])))]
-- | sometimes you need this special case, e.g. in linearization rules
getDefs :: Def -> Err [((Ident,Int), (Maybe G.Type, Maybe G.Term))]
getDefs d = case d of
DPatt id patts e -> do
id' <- transNamePos id
xs <- mapM tryMakeVar patts
e' <- transExp e
return [(id',(Nothing, Just (M.mkAbs xs e')))]
_ -> getDefsGen d
-- | accepts a pattern that is either a variable or a wild card
tryMakeVar :: Patt -> Err Ident
tryMakeVar p = do
p' <- transPatt p
case p' of
G.PV i -> return i
G.PW -> return identW
_ -> Bad $ "not a legal pattern in lambda binding" +++ GP.prt p'
transExp :: Exp -> Err G.Term
transExp x = case x of
EIdent id -> liftM G.Vr $ transIdent id
EConstr id -> liftM G.Con $ transIdent id
ECons id -> liftM G.Cn $ transIdent id
EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c)
EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c)
EString str -> return $ G.K str
ESort sort -> return $ G.Sort $ transSort sort
EInt n -> return $ G.EInt n
EFloat n -> return $ G.EFloat n
EMeta -> return $ G.Meta $ M.int2meta 0
EEmpty -> return G.Empty
-- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
EList i es -> do
i' <- transIdent i
es' <- mapM transExp (exps2list es)
return $ foldl G.App (G.Vr (mkListId i')) es'
EStrings [] -> return G.Empty
EStrings str -> return $ foldr1 G.C $ map G.K $ words str
ERecord defs -> erecord2term defs
ETupTyp _ _ -> do
let tups t = case t of
ETupTyp x y -> tups x ++ [y] -- right-associative parsing
_ -> [t]
es <- mapM transExp $ tups x
return $ G.RecType $ M.tuple2recordType es
ETuple tuplecomps -> do
es <- mapM transExp [e | TComp e <- tuplecomps]
return $ G.R $ M.tuple2record es
EProj exp id -> liftM2 G.P (transExp exp) (trLabel id)
EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp)
ETable cases -> liftM (G.T G.TRaw) (transCases cases)
ETTable exp cases ->
liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
EVTable exp cases ->
liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
ECase exp cases -> do
exp' <- transExp exp
cases' <- transCases cases
let annot = case exp' of
G.Typed _ t -> G.TTyped t
_ -> G.TRaw
return $ G.S (G.T annot cases') exp'
ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
EVariants exps -> liftM G.FV $ mapM transExp exps
EVariant exp0 exp -> do let fvList (G.FV xs) = xs
fvList t = [t]
exp0' <- transExp exp0
exp' <- transExp exp
return $ G.FV $ fvList exp0' ++ fvList exp'
EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts)
EStrs exps -> liftM G.Strs $ mapM transExp exps
ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp)
EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp)
EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp)
ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp)
EExample exp str -> liftM2 G.Example (transExp exp) (return str)
EProd decl exp -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp)
ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp)
EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp)
EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp)
ELet defs exp -> do
exp' <- transExp exp
defs0 <- mapM locdef2fields defs
defs' <- mapM tryLoc $ concat defs0
return $ M.mkLet defs' exp'
where
tryLoc (c,(mty,Just e)) = return (c,(mty,e))
tryLoc (c,_) = Bad $ "local definition of" +++ GP.prt c +++ "without value"
ELetb defs exp -> transExp $ ELet defs exp
EWhere exp defs -> transExp $ ELet defs exp
EPattType typ -> liftM G.EPattType (transExp typ)
EPatt patt -> liftM G.EPatt (transPatt patt)
ELString (LString str) -> return $ G.K (BS.unpack str) -- use the grammar encoding here
EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
_ -> Bad $ "translation not yet defined for" +++ printTree x ----
exps2list :: Exps -> [Exp]
exps2list NilExp = []
exps2list (ConsExp e es) = e : exps2list es
--- this is complicated: should we change Exp or G.Term ?
erecord2term :: [LocDef] -> Err G.Term
erecord2term ds = do
ds' <- mapM locdef2fields ds
mkR $ concat ds'
where
mkR fs = do
fs' <- transF fs
return $ case fs' of
Left ts -> G.RecType ts
Right ds -> G.R ds
transF [] = return $ Left [] --- empty record always interpreted as record type
transF fs@(f:_) = case f of
(lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
_ -> mapM tryR fs >>= return . Right
tryRT f = case f of
(lab,(Just ty,Nothing)) -> return (G.ident2label lab,ty)
_ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
tryR f = case f of
(lab,(mty, Just t)) -> return (G.ident2label lab,(mty,t))
_ -> Bad $ "illegal record field" +++ GP.prt (fst f)
locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))]
locdef2fields d = case d of
LDDecl ids t -> do
labs <- mapM transIdent ids
t' <- transExp t
return [(lab,(Just t',Nothing)) | lab <- labs]
LDDef ids e -> do
labs <- mapM transIdent ids
e' <- transExp e
return [(lab,(Nothing, Just e')) | lab <- labs]
LDFull ids t e -> do
labs <- mapM transIdent ids
t' <- transExp t
e' <- transExp e
return [(lab,(Just t', Just e')) | lab <- labs]
trLabel :: Label -> Err G.Label
trLabel x = case x of
LIdent (PIdent (_, s)) -> return $ G.LIdent s
LVar x -> return $ G.LVar $ fromInteger x
transSort :: Sort -> Ident
transSort Sort_Type = cType
transSort Sort_PType = cPType
transSort Sort_Tok = cTok
transSort Sort_Str = cStr
transSort Sort_Strs = cStrs
{-
--- no more used 7/1/2006 AR
transPatts :: Patt -> Err [G.Patt]
transPatts p = case p of
PDisj p1 p2 -> liftM2 (++) (transPatts p1) (transPatts p2)
PC id patts -> liftM (map (G.PC id) . combinations) $ mapM transPatts patts
PQC q id patts -> liftM (map (G.PP q id) . combinations) (mapM transPatts patts)
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LIdent $ concat lss
ps0 <- mapM transPatts ps
let ps' = combinations ps0
lss' <- mapM trLabel ls
let rss = map (zip lss') ps'
return $ map G.PR rss
PTup pcs -> do
ps0 <- mapM transPatts [e | PTComp e <- pcs]
let ps' = combinations ps0
return $ map (G.PR . M.tuple2recordPatt) ps'
_ -> liftM singleton $ transPatt p
-}
transPatt :: Patt -> Err G.Patt
transPatt x = case x of
PW -> return G.PW
PV id -> liftM G.PV $ transIdent id
PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
PCon id -> liftM2 G.PC (transIdent id) (return [])
PInt n -> return $ G.PInt n
PFloat n -> return $ G.PFloat n
PStr str -> return $ G.PString str
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LIdent $ concat lss
liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps)
PTup pcs ->
liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
PQC id0 id patts ->
liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2)
PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2)
PRep p -> liftM G.PRep (transPatt p)
PNeg p -> liftM G.PNeg (transPatt p)
PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p)
PChar -> return G.PChar
PChars s -> return $ G.PChars s
PMacro c -> liftM G.PMacro $ transIdent c
PM m c -> liftM2 G.PM (transIdent m) (transIdent c)
transBind :: Bind -> Err Ident
transBind x = case x of
BIdent id -> transIdent id
BWild -> return identW
transDecl :: Decl -> Err [G.Decl]
transDecl x = case x of
DDec binds exp -> do
xs <- mapM transBind binds
exp' <- transExp exp
return [(x,exp') | x <- xs]
DExp exp -> liftM (return . M.mkDecl) $ transExp exp
transCases :: [Case] -> Err [G.Case]
transCases = mapM transCase
transCase :: Case -> Err G.Case
transCase (Case p exp) = do
patt <- transPatt p
exp' <- transExp exp
return (patt,exp')
transEquation :: Equation -> Err G.Equation
transEquation x = case x of
Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp)
transAltern :: Altern -> Err (G.Term, G.Term)
transAltern x = case x of
Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp)
transParConstr :: ParConstr -> Err G.Param
transParConstr x = case x of
ParConstr id ddecls -> do
id' <- transIdent id
ddecls' <- mapM transDDecl ddecls
return (id',concat ddecls')
transDDecl :: DDecl -> Err [G.Decl]
transDDecl x = case x of
DDDec binds exp -> transDecl $ DDec binds exp
DDExp exp -> transDecl $ DExp exp
-- | to deal with the old format, sort judgements in two modules, forming
-- their names from a given string, e.g. file name or overriding user-given string
transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar
transOldGrammar opts name0 x = case x of
OldGr includes topdefs -> do --- includes must be collected separately
let moddefs = sortTopDefs topdefs
transGrammar $ Gr moddefs
where
sortTopDefs ds = [mkAbs a, mkCnc ops (c ++ r)]
where
ops = map fst ps
(a,r,c,ps) = foldr srt ([],[],[],[]) ds
srt d (a,r,c,ps) = case d of
DefCat catdefs -> (d:a,r,c,ps)
DefFun fundefs -> (d:a,r,c,ps)
DefFunData fundefs -> (d:a,r,c,ps)
DefDef defs -> (d:a,r,c,ps)
DefData pardefs -> (d:a,r,c,ps)
DefPar pardefs -> (a,d:r,c,ps)
DefOper defs -> (a,d:r,c,ps)
DefLintype defs -> (a,d:r,c,ps)
DefLincat defs -> (a,r,d:c,ps)
DefLindef defs -> (a,r,d:c,ps)
DefLin defs -> (a,r,d:c,ps)
DefPattern defs -> (a,r,d:c,ps)
DefFlag defs -> (a,r,d:c,ps) --- a guess
DefPrintCat printdefs -> (a,r,d:c,ps)
DefPrintFun printdefs -> (a,r,d:c,ps)
DefPrintOld printdefs -> (a,r,d:c,ps)
-- DefPackage m ds -> (a,r,c,(m,ds):ps) -- OBSOLETE
_ -> (a,r,c,ps)
mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a))
mkCnc ps r = MModule q (MTConcrete cncName absName) (MBody ne (OpenIn []) (topDefs r))
topDefs t = t
ne = NoExt
q = CMCompl
name = maybe name0 (++ ".gf") $ flag optName opts
absName = identPI $ maybe topic id $ flag optAbsName opts
resName = identPI $ maybe ("Res" ++ lang) id $ flag optResName opts
cncName = identPI $ maybe lang id $ flag optCncName opts
identPI s = PIdent ((0,0),BS.pack s)
(beg,rest) = span (/='.') name
(topic,lang) = case rest of -- to avoid overwriting old files
".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".cf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg)
[] -> ("Abs" ++ beg,"Cnc" ++ beg)
_:s -> (beg, takeWhile (/='.') s)
transInclude :: Include -> Err [FilePath]
transInclude x = Bad "Old GF with includes no more supported in GF 3.0"
newReservedWords :: [String]
newReservedWords =
words $ "abstract concrete interface incomplete " ++
"instance out open resource reuse transfer union with where"
termInPattern :: G.Term -> G.Term
termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
toP t = case t of
G.Vr x -> G.P t s
_ -> M.composSafeOp toP t
s = G.LIdent (BS.pack "s")
(xx,body) = abss [] t
abss xs t = case t of
G.Abs x b -> abss (x:xs) b
_ -> (reverse xs,t)
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixId (BS.pack "List")
mkConsId = prefixId (BS.pack "Cons")
mkBaseId = prefixId (BS.pack "Base")
prefixId :: BS.ByteString -> Ident -> Ident
prefixId pref id = identC (BS.append pref (ident2bs id))

2
src/GFC.hs
View File

@@ -7,7 +7,7 @@ import PGF.Data
import GF.Compile import GF.Compile
import GF.Compile.Export import GF.Compile.Export
import GF.Source.CF ---- should this be on a deeper level? AR 15/10/2008 import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option