From b783299b73b5c8a8229a45a830cf9b6be0be4f8c Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 7 Mar 2019 14:47:37 +0100 Subject: Rename module GF.Compile.ConcreteToCanonical to GF.Compile.GrammarToCanonical --- gf.cabal | 2 +- src/compiler/GF/Compile/ConcreteToCanonical.hs | 370 ------------------------- src/compiler/GF/Compile/ConcreteToHaskell.hs | 2 +- src/compiler/GF/Compile/GrammarToCanonical.hs | 368 ++++++++++++++++++++++++ src/compiler/GF/Compiler.hs | 2 +- 5 files changed, 371 insertions(+), 373 deletions(-) delete mode 100644 src/compiler/GF/Compile/ConcreteToCanonical.hs create mode 100644 src/compiler/GF/Compile/GrammarToCanonical.hs diff --git a/gf.cabal b/gf.cabal index 5142294f6..fb4acef69 100644 --- a/gf.cabal +++ b/gf.cabal @@ -189,7 +189,7 @@ Library GF.Compile.PGFtoJava GF.Haskell GF.Compile.ConcreteToHaskell - GF.Compile.ConcreteToCanonical + GF.Compile.GrammarToCanonical GF.Grammar.Canonical GF.Grammar.CanonicalJSON GF.Compile.PGFtoJS diff --git a/src/compiler/GF/Compile/ConcreteToCanonical.hs b/src/compiler/GF/Compile/ConcreteToCanonical.hs deleted file mode 100644 index 34c7bee73..000000000 --- a/src/compiler/GF/Compile/ConcreteToCanonical.hs +++ /dev/null @@ -1,370 +0,0 @@ --- | Translate grammars to Canonical form --- (a common intermediate representation to simplify export to other formats) -module GF.Compile.ConcreteToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where -import Data.List(nub,partition) -import qualified Data.Map as M -import qualified Data.Set as S -import GF.Data.ErrM -import GF.Text.Pretty -import GF.Grammar.Grammar -import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) -import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt) -import GF.Grammar.Lockfield(isLockLabel) -import GF.Grammar.Predef(cPredef,cInts) -import GF.Compile.Compute.Predef(predef) -import GF.Compile.Compute.Value(Predefined(..)) -import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) -import GF.Infra.Option(optionsPGF) -import PGF.Internal(Literal(..)) -import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) -import GF.Grammar.Canonical as C -import Debug.Trace - --- | Generate Canonical code for the named abstract syntax and all associated --- concrete syntaxes -grammar2canonical opts absname gr = - Grammar (abstract2canonical absname gr) - (map snd (concretes2canonical opts absname gr)) - --- | Generate Canonical code for the named abstract syntax -abstract2canonical absname gr = - Abstract (modId absname) (convFlags gr absname) cats funs - where - cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs] - - funs = [FunDef (gId f) (convType ty) | - ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs] - - adefs = allOrigInfos gr absname - - convCtx = maybe [] (map convHypo . unLoc) - convHypo (bt,name,t) = - case typeForm t of - ([],(_,cat),[]) -> gId cat -- !! - - convType t = - case typeForm t of - (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as) - where - bs = map convHypo' hyps - as = map convType args - - convHypo' (bt,name,t) = TypeBinding (gId name) (convType t) - - --- | Generate Canonical code for the all concrete syntaxes associated with --- the named abstract syntax in given the grammar. -concretes2canonical opts absname gr = - [(cncname,concrete2canonical opts gr cenv absname cnc cncmod) - | let cenv = resourceValues opts gr, - cnc<-allConcretes gr absname, - let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath - Ok cncmod = lookupModule gr cnc - ] - --- | Generate Canonical GF for the given concrete module. --- The only options that make a difference are --- @-haskell=noprefix@ and @-haskell=variants@. -concrete2canonical opts gr cenv absname cnc modinfo = - Concrete (modId cnc) (modId absname) (convFlags gr cnc) - (neededParamTypes S.empty (params defs)) - [lincat|(_,Left lincat)<-defs] - [lin|(_,Right lin)<-defs] - where - defs = concatMap (toCanonical gr absname cenv) . - M.toList $ - jments modinfo - - params = S.toList . S.unions . map fst - - neededParamTypes have [] = [] - neededParamTypes have (q:qs) = - if q `S.member` have - then neededParamTypes have qs - else let ((got,need),def) = paramType gr q - in def++neededParamTypes (S.union got have) (S.toList need++qs) - -toCanonical gr absname cenv (name,jment) = - case jment of - CncCat (Just (L loc typ)) _ _ pprn _ -> - [(pts,Left (LincatDef (gId name) (convType ntyp)))] - where - pts = paramTypes gr ntyp - ntyp = nf loc typ - CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> - [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))] - where - tts = tableTypes gr [e'] - - e' = unAbs (length params) $ - nf loc (mkAbs params (mkApp def (map Vr args))) - params = [(b,x)|(b,x,_)<-ctx] - args = map snd params - - AnyInd _ m -> case lookupOrigInfo gr (m,name) of - Ok (m,jment) -> toCanonical gr absname cenv (name,jment) - _ -> [] - _ -> [] - where - nf loc = normalForm cenv (L loc name) --- aId n = prefixIdent "A." (gId n) - - unAbs 0 t = t - unAbs n (Abs _ _ t) = unAbs (n-1) t - unAbs _ t = t - -tableTypes gr ts = S.unions (map tabtys ts) - where - tabtys t = - case t of - V t cc -> S.union (paramTypes gr t) (tableTypes gr cc) - T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs)) - _ -> collectOp tabtys t - -paramTypes gr t = - case t of - RecType fs -> S.unions (map (paramTypes gr.snd) fs) - Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2) - App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta) - Sort _ -> S.empty - EInt _ -> S.empty - Q q -> lookup q - QC q -> lookup q - FV ts -> S.unions (map (paramTypes gr) ts) - _ -> ignore - where - lookup q = case lookupOrigInfo gr q of - Ok (_,ResOper _ (Just (L _ t))) -> - S.insert q (paramTypes gr t) - Ok (_,ResParam {}) -> S.singleton q - _ -> ignore - - ignore = trace ("Ignore: "++show t) S.empty - - -convert gr = convert' gr [] - -convert' gr vs = ppT - where - ppT0 = convert' gr vs - ppTv vs' = convert' gr vs' - - ppT t = - case t of --- Abs b x t -> ... --- V ty ts -> VTableValue (convType ty) (map ppT ts) - V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts] - where - Ok pts = allParamValues gr ty - Ok ps = mapM term2patt pts - T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs) - S t p -> selection (ppT t) (ppT p) - C t1 t2 -> concatValue (ppT t1) (ppT t2) - App f a -> ap (ppT f) (ppT a) - R r -> RecordValue (fields r) - P t l -> projection (ppT t) (lblId l) - Vr x -> VarValue (gId x) - Cn x -> VarValue (gId x) -- hmm - Con c -> ParamConstant (Param (gId c) []) - Sort k -> VarValue (gId k) - EInt n -> IntConstant n - Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n)) - QC (m,n) -> ParamConstant (Param (gId (qual m n)) []) - K s -> StrConstant s - Empty -> StrConstant "" - FV ts -> VariantValue (map ppT ts) - Alts t' vs -> alts vs (ppT t') - _ -> error $ "convert' "++show t - - ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) - - ppPredef n = - case predef n of - Ok BIND -> p "BIND" - Ok SOFT_BIND -> p "SOFT_BIND" - Ok SOFT_SPACE -> p "SOFT_SPACE" - Ok CAPIT -> p "CAPIT" - Ok ALL_CAPIT -> p "ALL_CAPIT" - _ -> VarValue (gId n) - where - p = PredefValue . PredefId - - ppP p = - case p of - PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) - PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps)) - PR r -> RecordPattern (fields r) {- - PW -> WildPattern - PV x -> VarP x - PString s -> Lit (show s) -- !! - PInt i -> Lit (show i) - PFloat x -> Lit (show x) - PT _ p -> ppP p - PAs x p -> AsP x (ppP p) -} - where - fields = map field . filter (not.isLockLabel.fst) - field (l,p) = RecordRow (lblId l) (ppP p) - --- patToParam p = case ppP p of ParamPattern pv -> pv - --- token s = single (c "TK" `Ap` lit s) - - alts vs = PreValue (map alt vs) - where - alt (t,p) = (pre p,ppT0 t) - - pre (K s) = [s] - pre (Strs ts) = concatMap pre ts - pre (EPatt p) = pat p - pre t = error $ "pre "++show t - - pat (PString s) = [s] - pat (PAlt p1 p2) = pat p1++pat p2 - pat p = error $ "pat "++show p - - fields = map field . filter (not.isLockLabel.fst) - field (l,(_,t)) = RecordRow (lblId l) (ppT t) - --c = Const - --c = VarValue . VarValueId - --lit s = c (show s) -- hmm - - ap f a = case f of - ParamConstant (Param p ps) -> - ParamConstant (Param p (ps++[a])) - _ -> error $ "convert' ap: "++render (ppA f <+> ppA a) - -concatValue v1 v2 = - case (v1,v2) of - (StrConstant "",_) -> v2 - (_,StrConstant "") -> v1 - _ -> ConcatValue v1 v2 - -projection r l = maybe (Projection r l) id (proj r l) - -proj r l = - case r of - RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of - [v] -> Just v - _ -> Nothing - _ -> Nothing - -selection t v = - case t of - TableValue tt r -> - case nub [rv|TableRowValue _ rv<-keep] of - [rv] -> rv - _ -> Selection (TableValue tt r') v - where - r' = if null discard - then r - else keep++[TableRowValue WildPattern impossible] - (keep,discard) = partition (mightMatchRow v) r - _ -> Selection t v - -impossible = ErrorValue "impossible" - -mightMatchRow v (TableRowValue p _) = - case p of - WildPattern -> True - _ -> mightMatch v p - -mightMatch v p = - case v of - ConcatValue _ _ -> False - ParamConstant (Param c1 pvs) -> - case p of - ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps && - and [mightMatch v p|(v,p)<-zip pvs pps] - _ -> False - RecordValue rv -> - case p of - RecordPattern rp -> - and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp] - _ -> False - _ -> True - -patVars p = - case p of - PV x -> [x] - PAs x p -> x:patVars p - _ -> collectPattOp patVars p - -convType = ppT - where - ppT t = - case t of - Table ti tv -> TableType (ppT ti) (ppT tv) - RecType rt -> RecordType (convFields rt) --- App tf ta -> TAp (ppT tf) (ppT ta) --- FV [] -> tcon0 (identS "({-empty variant-})") - Sort k -> convSort k --- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal - FV (t:ts) -> ppT t -- !! - QC (m,n) -> ParamType (ParamTypeId (gId (qual m n))) - Q (m,n) -> ParamType (ParamTypeId (gId (qual m n))) - _ -> error $ "Missing case in convType for: "++show t - - convFields = map convField . filter (not.isLockLabel.fst) - convField (l,r) = RecordRow (lblId l) (ppT r) - - convSort k = case showIdent k of - "Float" -> FloatType - "Int" -> IntType - "Str" -> StrType - _ -> error ("convSort "++show k) - -toParamType t = case convType t of - ParamType pt -> pt - _ -> error ("toParamType "++show t) - -toParamId t = case toParamType t of - ParamTypeId p -> p - -paramType gr q@(_,n) = - case lookupOrigInfo gr q of - Ok (m,ResParam (Just (L _ ps)) _) - {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> - ((S.singleton (m,n),argTypes ps), - [ParamDef name (map (param m) ps)] - ) - where name = gId (qual m n) - Ok (m,ResOper _ (Just (L _ t))) - | m==cPredef && n==cInts -> - ((S.empty,S.empty),[]) {- - ((S.singleton (m,n),S.empty), - [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-} - | otherwise -> - ((S.singleton (m,n),paramTypes gr t), - [ParamAliasDef (gId (qual m n)) (convType t)]) - _ -> ((S.empty,S.empty),[]) - where - param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx] - argTypes = S.unions . map argTypes1 - argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] - -qual :: ModuleName -> Ident -> Ident -qual m = prefixIdent (render m++"_") - - -lblId = LabelId . render -- hmm -modId (MN m) = ModId (showIdent m) - -class FromIdent i where gId :: Ident -> i - -instance FromIdent VarId where - gId i = if isWildIdent i then Anonymous else VarId (showIdent i) - -instance FromIdent C.FunId where gId = C.FunId . showIdent -instance FromIdent CatId where gId = CatId . showIdent -instance FromIdent ParamId where gId = ParamId . showIdent -instance FromIdent VarValueId where gId = VarValueId . showIdent - -convFlags gr mn = - Flags [(n,convLit v) | - (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] - where - convLit l = - case l of - LStr s -> Str s - LInt i -> C.Int i - LFlt d -> Flt d diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 51ed5242e..804db9d50 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -11,7 +11,7 @@ import GF.Infra.Ident(Ident,identS,identW,prefixIdent) import GF.Infra.Option import GF.Haskell as H import GF.Grammar.Canonical as C -import GF.Compile.ConcreteToCanonical +import GF.Compile.GrammarToCanonical import Debug.Trace(trace) -- | Generate Haskell code for the all concrete syntaxes associated with diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs new file mode 100644 index 000000000..4bd9130b2 --- /dev/null +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -0,0 +1,368 @@ +-- | Translate grammars to Canonical form +-- (a common intermediate representation to simplify export to other formats) +module GF.Compile.GrammarToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where +import Data.List(nub,partition) +import qualified Data.Map as M +import qualified Data.Set as S +import GF.Data.ErrM +import GF.Text.Pretty +import GF.Grammar.Grammar +import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) +import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt) +import GF.Grammar.Lockfield(isLockLabel) +import GF.Grammar.Predef(cPredef,cInts) +import GF.Compile.Compute.Predef(predef) +import GF.Compile.Compute.Value(Predefined(..)) +import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) +import GF.Infra.Option(optionsPGF) +import PGF.Internal(Literal(..)) +import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) +import GF.Grammar.Canonical as C +import Debug.Trace + +-- | Generate Canonical code for the named abstract syntax and all associated +-- concrete syntaxes +grammar2canonical opts absname gr = + Grammar (abstract2canonical absname gr) + (map snd (concretes2canonical opts absname gr)) + +-- | Generate Canonical code for the named abstract syntax +abstract2canonical absname gr = + Abstract (modId absname) (convFlags gr absname) cats funs + where + cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs] + + funs = [FunDef (gId f) (convType ty) | + ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs] + + adefs = allOrigInfos gr absname + + convCtx = maybe [] (map convHypo . unLoc) + convHypo (bt,name,t) = + case typeForm t of + ([],(_,cat),[]) -> gId cat -- !! + + convType t = + case typeForm t of + (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as) + where + bs = map convHypo' hyps + as = map convType args + + convHypo' (bt,name,t) = TypeBinding (gId name) (convType t) + + +-- | Generate Canonical code for the all concrete syntaxes associated with +-- the named abstract syntax in given the grammar. +concretes2canonical opts absname gr = + [(cncname,concrete2canonical gr cenv absname cnc cncmod) + | let cenv = resourceValues opts gr, + cnc<-allConcretes gr absname, + let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath + Ok cncmod = lookupModule gr cnc + ] + +-- | Generate Canonical GF for the given concrete module. +concrete2canonical gr cenv absname cnc modinfo = + Concrete (modId cnc) (modId absname) (convFlags gr cnc) + (neededParamTypes S.empty (params defs)) + [lincat|(_,Left lincat)<-defs] + [lin|(_,Right lin)<-defs] + where + defs = concatMap (toCanonical gr absname cenv) . + M.toList $ + jments modinfo + + params = S.toList . S.unions . map fst + + neededParamTypes have [] = [] + neededParamTypes have (q:qs) = + if q `S.member` have + then neededParamTypes have qs + else let ((got,need),def) = paramType gr q + in def++neededParamTypes (S.union got have) (S.toList need++qs) + +toCanonical gr absname cenv (name,jment) = + case jment of + CncCat (Just (L loc typ)) _ _ pprn _ -> + [(pts,Left (LincatDef (gId name) (convType ntyp)))] + where + pts = paramTypes gr ntyp + ntyp = nf loc typ + CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> + [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))] + where + tts = tableTypes gr [e'] + + e' = unAbs (length params) $ + nf loc (mkAbs params (mkApp def (map Vr args))) + params = [(b,x)|(b,x,_)<-ctx] + args = map snd params + + AnyInd _ m -> case lookupOrigInfo gr (m,name) of + Ok (m,jment) -> toCanonical gr absname cenv (name,jment) + _ -> [] + _ -> [] + where + nf loc = normalForm cenv (L loc name) +-- aId n = prefixIdent "A." (gId n) + + unAbs 0 t = t + unAbs n (Abs _ _ t) = unAbs (n-1) t + unAbs _ t = t + +tableTypes gr ts = S.unions (map tabtys ts) + where + tabtys t = + case t of + V t cc -> S.union (paramTypes gr t) (tableTypes gr cc) + T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs)) + _ -> collectOp tabtys t + +paramTypes gr t = + case t of + RecType fs -> S.unions (map (paramTypes gr.snd) fs) + Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2) + App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta) + Sort _ -> S.empty + EInt _ -> S.empty + Q q -> lookup q + QC q -> lookup q + FV ts -> S.unions (map (paramTypes gr) ts) + _ -> ignore + where + lookup q = case lookupOrigInfo gr q of + Ok (_,ResOper _ (Just (L _ t))) -> + S.insert q (paramTypes gr t) + Ok (_,ResParam {}) -> S.singleton q + _ -> ignore + + ignore = trace ("Ignore: "++show t) S.empty + + +convert gr = convert' gr [] + +convert' gr vs = ppT + where + ppT0 = convert' gr vs + ppTv vs' = convert' gr vs' + + ppT t = + case t of +-- Abs b x t -> ... +-- V ty ts -> VTableValue (convType ty) (map ppT ts) + V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts] + where + Ok pts = allParamValues gr ty + Ok ps = mapM term2patt pts + T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs) + S t p -> selection (ppT t) (ppT p) + C t1 t2 -> concatValue (ppT t1) (ppT t2) + App f a -> ap (ppT f) (ppT a) + R r -> RecordValue (fields r) + P t l -> projection (ppT t) (lblId l) + Vr x -> VarValue (gId x) + Cn x -> VarValue (gId x) -- hmm + Con c -> ParamConstant (Param (gId c) []) + Sort k -> VarValue (gId k) + EInt n -> IntConstant n + Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n)) + QC (m,n) -> ParamConstant (Param (gId (qual m n)) []) + K s -> StrConstant s + Empty -> StrConstant "" + FV ts -> VariantValue (map ppT ts) + Alts t' vs -> alts vs (ppT t') + _ -> error $ "convert' "++show t + + ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) + + ppPredef n = + case predef n of + Ok BIND -> p "BIND" + Ok SOFT_BIND -> p "SOFT_BIND" + Ok SOFT_SPACE -> p "SOFT_SPACE" + Ok CAPIT -> p "CAPIT" + Ok ALL_CAPIT -> p "ALL_CAPIT" + _ -> VarValue (gId n) + where + p = PredefValue . PredefId + + ppP p = + case p of + PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) + PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps)) + PR r -> RecordPattern (fields r) {- + PW -> WildPattern + PV x -> VarP x + PString s -> Lit (show s) -- !! + PInt i -> Lit (show i) + PFloat x -> Lit (show x) + PT _ p -> ppP p + PAs x p -> AsP x (ppP p) -} + where + fields = map field . filter (not.isLockLabel.fst) + field (l,p) = RecordRow (lblId l) (ppP p) + +-- patToParam p = case ppP p of ParamPattern pv -> pv + +-- token s = single (c "TK" `Ap` lit s) + + alts vs = PreValue (map alt vs) + where + alt (t,p) = (pre p,ppT0 t) + + pre (K s) = [s] + pre (Strs ts) = concatMap pre ts + pre (EPatt p) = pat p + pre t = error $ "pre "++show t + + pat (PString s) = [s] + pat (PAlt p1 p2) = pat p1++pat p2 + pat p = error $ "pat "++show p + + fields = map field . filter (not.isLockLabel.fst) + field (l,(_,t)) = RecordRow (lblId l) (ppT t) + --c = Const + --c = VarValue . VarValueId + --lit s = c (show s) -- hmm + + ap f a = case f of + ParamConstant (Param p ps) -> + ParamConstant (Param p (ps++[a])) + _ -> error $ "convert' ap: "++render (ppA f <+> ppA a) + +concatValue v1 v2 = + case (v1,v2) of + (StrConstant "",_) -> v2 + (_,StrConstant "") -> v1 + _ -> ConcatValue v1 v2 + +projection r l = maybe (Projection r l) id (proj r l) + +proj r l = + case r of + RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of + [v] -> Just v + _ -> Nothing + _ -> Nothing + +selection t v = + case t of + TableValue tt r -> + case nub [rv|TableRowValue _ rv<-keep] of + [rv] -> rv + _ -> Selection (TableValue tt r') v + where + r' = if null discard + then r + else keep++[TableRowValue WildPattern impossible] + (keep,discard) = partition (mightMatchRow v) r + _ -> Selection t v + +impossible = ErrorValue "impossible" + +mightMatchRow v (TableRowValue p _) = + case p of + WildPattern -> True + _ -> mightMatch v p + +mightMatch v p = + case v of + ConcatValue _ _ -> False + ParamConstant (Param c1 pvs) -> + case p of + ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps && + and [mightMatch v p|(v,p)<-zip pvs pps] + _ -> False + RecordValue rv -> + case p of + RecordPattern rp -> + and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp] + _ -> False + _ -> True + +patVars p = + case p of + PV x -> [x] + PAs x p -> x:patVars p + _ -> collectPattOp patVars p + +convType = ppT + where + ppT t = + case t of + Table ti tv -> TableType (ppT ti) (ppT tv) + RecType rt -> RecordType (convFields rt) +-- App tf ta -> TAp (ppT tf) (ppT ta) +-- FV [] -> tcon0 (identS "({-empty variant-})") + Sort k -> convSort k +-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal + FV (t:ts) -> ppT t -- !! + QC (m,n) -> ParamType (ParamTypeId (gId (qual m n))) + Q (m,n) -> ParamType (ParamTypeId (gId (qual m n))) + _ -> error $ "Missing case in convType for: "++show t + + convFields = map convField . filter (not.isLockLabel.fst) + convField (l,r) = RecordRow (lblId l) (ppT r) + + convSort k = case showIdent k of + "Float" -> FloatType + "Int" -> IntType + "Str" -> StrType + _ -> error ("convSort "++show k) + +toParamType t = case convType t of + ParamType pt -> pt + _ -> error ("toParamType "++show t) + +toParamId t = case toParamType t of + ParamTypeId p -> p + +paramType gr q@(_,n) = + case lookupOrigInfo gr q of + Ok (m,ResParam (Just (L _ ps)) _) + {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> + ((S.singleton (m,n),argTypes ps), + [ParamDef name (map (param m) ps)] + ) + where name = gId (qual m n) + Ok (m,ResOper _ (Just (L _ t))) + | m==cPredef && n==cInts -> + ((S.empty,S.empty),[]) {- + ((S.singleton (m,n),S.empty), + [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-} + | otherwise -> + ((S.singleton (m,n),paramTypes gr t), + [ParamAliasDef (gId (qual m n)) (convType t)]) + _ -> ((S.empty,S.empty),[]) + where + param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx] + argTypes = S.unions . map argTypes1 + argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] + +qual :: ModuleName -> Ident -> Ident +qual m = prefixIdent (render m++"_") + + +lblId = LabelId . render -- hmm +modId (MN m) = ModId (showIdent m) + +class FromIdent i where gId :: Ident -> i + +instance FromIdent VarId where + gId i = if isWildIdent i then Anonymous else VarId (showIdent i) + +instance FromIdent C.FunId where gId = C.FunId . showIdent +instance FromIdent CatId where gId = CatId . showIdent +instance FromIdent ParamId where gId = ParamId . showIdent +instance FromIdent VarValueId where gId = VarValueId . showIdent + +convFlags gr mn = + Flags [(n,convLit v) | + (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] + where + convLit l = + case l of + LStr s -> Str s + LInt i -> C.Int i + LFlt d -> Flt d diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index efb1ae70f..4003285b8 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -7,7 +7,7 @@ import GF.Compile as S(batchCompile,link,srcAbsName) import GF.CompileInParallel as P(parallelBatchCompile) import GF.Compile.Export import GF.Compile.ConcreteToHaskell(concretes2haskell) -import GF.Compile.ConcreteToCanonical--(concretes2canonical) +import GF.Compile.GrammarToCanonical--(concretes2canonical) import GF.Compile.CFGtoPGF import GF.Compile.GetGrammar import GF.Grammar.BNFC -- cgit v1.2.3