forked from GitHub/gf-core
clean up the GF.Grammar API
This commit is contained in:
krasimir
@@ -5,10 +5,10 @@ import PGF.Data
|
||||
|
||||
import GF.Compile
|
||||
import GF.Grammar.Grammar (SourceGrammar) -- for cc command
|
||||
import GF.Grammar.CF
|
||||
import GF.Infra.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.Data.ErrM
|
||||
import GF.Source.CF
|
||||
|
||||
import Data.List (nubBy)
|
||||
import System.FilePath
|
||||
|
||||
@@ -25,10 +25,6 @@ import GF.Infra.Option
|
||||
import GF.Infra.Modules
|
||||
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 Control.Monad
|
||||
|
||||
@@ -23,7 +23,7 @@ module GF.Compile.AbsCompute (LookDef,
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Compile.Compute
|
||||
|
||||
|
||||
@@ -14,7 +14,7 @@ import GF.Grammar.Predef
|
||||
import GF.Grammar.Printer
|
||||
import GF.Grammar.Grammar
|
||||
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.Compile.Compute as Compute ----
|
||||
import qualified GF.Infra.Modules as M
|
||||
|
||||
@@ -28,7 +28,6 @@ import GF.Infra.Option
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules
|
||||
import GF.Data.Operations
|
||||
import qualified GF.Source.AbsGF as S
|
||||
import GF.Grammar.Lexer
|
||||
import GF.Grammar.Parser
|
||||
import GF.Grammar.Grammar
|
||||
|
||||
@@ -22,9 +22,8 @@ module GF.Compile.TC (AExp(..),
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Grammar.Printer
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (sortBy)
|
||||
|
||||
@@ -22,10 +22,9 @@ module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should n
|
||||
import GF.Data.Operations
|
||||
|
||||
import GF.Infra.CheckM
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Unify
|
||||
import GF.Grammar.Printer
|
||||
import GF.Compile.Refresh
|
||||
import GF.Compile.AbsCompute
|
||||
import GF.Compile.TC
|
||||
|
||||
@@ -12,12 +12,12 @@
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Abstract (
|
||||
module GF.Grammar (
|
||||
|
||||
module GF.Infra.Ident,
|
||||
module GF.Grammar.Grammar,
|
||||
module GF.Grammar.Values,
|
||||
module GF.Grammar.Macros,
|
||||
module GF.Infra.Ident,
|
||||
module GF.Grammar.MMacros,
|
||||
module GF.Grammar.Printer,
|
||||
|
||||
@@ -12,7 +12,7 @@
|
||||
-- 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.Macros
|
||||
File diff suppressed because one or more lines are too long
@@ -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
|
||||
@@ -17,7 +17,7 @@
|
||||
|
||||
module GF.Grammar.Unify (unifyVal) where
|
||||
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Grammar
|
||||
import GF.Data.Operations
|
||||
|
||||
import Text.PrettyPrint
|
||||
|
||||
@@ -33,7 +33,7 @@ module GF.Infra.Modules (
|
||||
IdentM(..),
|
||||
abstractOfConcrete, abstractModOfConcrete,
|
||||
lookupModule, lookupModuleType, lookupInfo,
|
||||
lookupPosition, showPosition, ppPosition,
|
||||
lookupPosition, ppPosition,
|
||||
isModAbs, isModRes, isModCnc, isModTrans,
|
||||
sameMType, isCompilableModule, isCompleteModule,
|
||||
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 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 mo i = case lookupPosition mo i of
|
||||
Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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 | '_' | '\'')* ;
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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])
|
||||
|
||||
|
||||
@@ -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))
|
||||
@@ -7,7 +7,7 @@ import PGF.Data
|
||||
import GF.Compile
|
||||
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.Option
|
||||
|
||||
Reference in New Issue
Block a user