From 1f60646f41104dcf406bfc3bd9dbf16422c022a9 Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 6 Jan 2015 16:48:03 +0000 Subject: [PATCH] More work on translating linearization functions to Haskell Many Phrasebook languages can now be converted to compilable Haskell code. Some languages (Fre, Hin, Snd, Urd) generate too much Haskell code to be practically useful (e.g. 338MB for Fre). One language (Fin) took too long to convert to Haskell. One language (Pes) has problems with name clashes in the generated Haskell code. STILL TODO: - variants - pre { ... } - reduce code duplication for large tables - generate qualified names to avoid name clashes --- src/compiler/GF/Compile/ConcreteToHaskell.hs | 135 +++++++++++++------ 1 file changed, 93 insertions(+), 42 deletions(-) diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index a52d00e14..783cce9b8 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -1,5 +1,5 @@ module GF.Compile.ConcreteToHaskell where -import Data.List(sort,sortBy,(\\)) +import Data.List(sort,sortBy) import Data.Function(on) import qualified Data.Map as M import qualified Data.Set as S @@ -8,14 +8,13 @@ import GF.Data.Utilities(mapSnd) import GF.Text.Pretty import GF.Grammar.Grammar import GF.Grammar.Lookup(lookupFunType,allParamValues,lookupOrigInfo,allOrigInfos) -import GF.Grammar.Macros(typeForm,collectOp) +import GF.Grammar.Macros(typeForm,collectOp,mkAbs,mkApp) import GF.Grammar.Lockfield(isLockLabel) -import GF.Grammar.Predef(cPredef) +import GF.Grammar.Predef(cPredef,cInts) import GF.Compile.Compute.Predef(predef) import GF.Compile.Compute.Value(Predefined(..)) -import GF.Infra.Ident(Ident,identS) --,moduleNameS +import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS import GF.Infra.Option -import GF.Grammar.Printer(getAbs) import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) import Debug.Trace @@ -93,18 +92,21 @@ toHaskell gId gr absname cenv (name,jment) = CncCat (Just (L loc typ)) _ _ pprn _ -> [(Nothing,("type"<+>"Lin"<>name,nf loc typ))] CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> - [(Just cat,("lin"<>cat<+>lhs,coerce lincat rhs))] +-- trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $ + [(Just cat,("lin"<>cat<+>lhs,coerce [] lincat rhs))] where Ok abstype = lookupFunType gr absname name (absctx,abscat,absargs) = typeForm abstype - (xs,e') = getAbs (nf loc def) - args = map snd xs + e' = unAbs (length params) $ + nf loc (mkAbs params (mkApp def (map Vr args))) + params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx] + args = map snd params abs_args = map ("abs_"<>) args lhs = if null args then aId name else parens (aId name<+>hsep abs_args) rhs = foldr letlin e' (zip args absctx) letlin (a,(_,_,at)) = - Let (a,(Nothing,(App (con ("lin"++render at)) (con ("abs_"++render a))))) + Let (a,(Just (con ("Lin"++render at)),(App (con ("lin"++render at)) (con ("abs_"++render a))))) AnyInd _ m -> case lookupOrigInfo gr (m,name) of Ok (m,jment) -> toHaskell gId gr absname cenv (name,jment) _ -> [] @@ -113,6 +115,11 @@ toHaskell gId gr absname cenv (name,jment) = nf loc = normalForm cenv (L loc name) aId n = "A."<>gId n + unAbs 0 t = t + unAbs n (Abs _ _ t) = unAbs (n-1) t + unAbs _ t = t + + con = Cn . identS tableTypes gr ts = S.unions (map tabtys ts) @@ -127,13 +134,17 @@ 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))) -> paramTypes gr t + Ok (_,ResOper _ (Just (L _ t))) -> + S.insert q (paramTypes gr t) Ok (_,ResParam {}) -> S.singleton q _ -> ignore @@ -152,23 +163,33 @@ records ts = S.unions (map recs ts) labels = sort . filter (not . isLockLabel) . map fst -coerce ty t = +coerce env ty t = case (ty,t) of - (_,Let d t) -> Let d (coerce ty t) - (_,FV ts) -> FV (map (coerce ty) ts) - (Table ti tv,V _ ts) -> V ti (map (coerce tv) ts) - (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce tv) cs) + (_,Let d t) -> Let d (coerce (extend env d) ty t) + (_,FV ts) -> FV (map (coerce env ty) ts) + (Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts) + (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs) (RecType rt,R r) -> - R [(l,(Just ft,coerce ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]] + R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]] + (RecType rt,Vr x)-> + case lookup x env of + Just ty' | ty'/=ty -> + --trace ("coerce "++render ty'++" to "++render ty) $ + App (to_rcon (map fst rt)) t + _ -> trace ("no coerce to "++render ty) t + _ -> t _ -> t - + where + extend env (x,(Just ty,rhs)) = (x,ty):env + extend env _ = env convert gId = convert' False gId convertA gId = convert' True gId convert' atomic gId gr = if atomic then ppA else ppT where - ppT t = + ppT = ppT' False + ppT' loop t = case t of Let (x,(_,xt)) t -> sep ["let"<+>x<+>"="<+>ppT xt,"in"<+>ppT t] Abs b x t -> "\\"<+>x<+>"->"<+>ppT t @@ -176,33 +197,38 @@ convert' atomic gId gr = if atomic then ppA else ppT T (TTyped ty) cs -> hang "\\case" 2 (vcat (map ppCase cs)) S t p -> hang (ppB t) 4 (ppA p) C t1 t2 -> hang (ppA t1<+>"++") 4 (ppA t2) - _ -> ppB t + _ -> ppB' loop t ppCase (p,t) = hang (ppP p <+> "->") 4 (ppT t) - ppB t = + ppB = ppB' False + ppB' loop t = case t of App f a -> ppB f<+>ppA a R r -> rcon (map fst r)<+>fsep (fields r) P t l -> ppB (proj l)<+>ppA t FV [] -> "error"<+>doubleQuotes "empty variant" - _ -> ppA t + _ -> ppA' loop t - ppA t = + ppA = ppA' False + + ppA' True t = error $ "Missing case in convert': "++show t + ppA' loop t = case t of Vr x -> pp x Cn x -> pp x Con c -> gId c Sort k -> pp k + EInt n -> pp n Q (m,n) -> if m==cPredef then ppPredef n else pp n QC (m,n) -> gId n K s -> token s Empty -> pp "[]" - FV (t:ts) -> ppA t -- !! - Alts t _ -> ppA t -- !!! - _ -> {-trace (show t) $-} parens (ppT t) + FV (t:ts) -> "{-variants-}"<>ppA t -- !! + Alts t _ -> "{-alts-}"<>ppA t -- !!! + _ -> parens (ppT' True t) ppPredef n = case predef n of @@ -238,39 +264,58 @@ convert' atomic gId gr = if atomic then ppA else ppT enumAll ty = case allParamValues gr ty of Ok ts -> ts -convType gId = ppT +convType = convType' False +convTypeA = convType' True + +convType' atomic gId = if atomic then ppA else ppT where - ppT t = + ppT = ppT' False + ppT' loop t = case t of Table ti tv -> ppB ti <+> "->" <+> ppT tv - _ -> ppB t + _ -> ppB' loop t - ppB t = + ppB = ppB' False + ppB' loop t = case t of RecType rt -> rcon (map fst rt)<+>fsep (fields rt) - _ -> ppA t + App tf ta -> ppB tf <+> ppA ta + FV [] -> pp "({-empty variant-})" + _ -> ppA' loop t - ppA t = + ppA = ppA' False + ppA' True t = error $ "Missing case in convType for: "++show t + ppA' loop t = case t of Sort k -> pp k + EInt n -> parens ("{-"<>n<>"-}") -- type level numeric literal + FV (t:ts) -> "{-variants-}"<>ppA t -- !! QC (m,n) -> gId n - _ -> {-trace (show t) $-} parens (ppT t) + Q (m,n) -> gId n + _ -> {-trace (show t) $-} parens (ppT' True t) fields = map (ppA.snd) . sort . filter (not.isLockLabel.fst) proj l = con ("proj_"++render l) -rcon ls = con ("R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])) +rcon = con . rcon_name +rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)]) +to_rcon = con . ("to_"++) . rcon_name recordType ls = "data"<+>app<+>"="<+>app <+> "deriving (Eq,Ord,Show)" $+$ - vcat (map projection ls) $+$ "" + vcat (zipWith projection vs ls) $+$ + to_rcon ls<+>"r"<+>"="<+>cn<+>fsep [parens (proj l<+>"r")|l<-ls] $+$ "" where - n = rcon ls - app = n<+>ls + cn = rcon ls + -- Not all record labels are syntactically correct as type variables in Haskell + -- app = cn<+>ls + app = cn<+>hsep vs -- don't reuse record labels + vs = ["t"<>i|i<-[1..n]] + n = length ls - projection l = - hang ("instance"<+>"Has_"<>l<+>parens app<+>l<+>"where") 4 - (proj l<+>parens app<+>"="<+>l) + projection v l = + hang ("instance"<+>"Has_"<>l<+>parens app<+>v<+>"where") 4 + (proj l<+>parens app<+>"="<+>v) labelClass l = hang ("class"<+>"Has_"<>l<+>"r"<+>"a"<+>"| r -> a"<+>"where") 4 @@ -279,13 +324,19 @@ labelClass l = paramType gId gr q@(_,n) = case lookupOrigInfo gr q of Ok (m,ResParam (Just (L _ ps)) _) - | True {-m/=cPredef && m/=moduleNameS "Prelude"-} -> + {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> ((S.singleton (m,n),argTypes ps), - "data"<+>gId (snd q)<+>"="<+> + "data"<+>gId n<+>"="<+> sep [fsep (punctuate " |" (map param ps)), pp "deriving (Eq,Ord,Show)"]) + Ok (m,ResOper _ (Just (L _ t))) + | m==cPredef && n==cInts -> + ((S.singleton (m,n),S.empty),pp "type GInts n = Int") + | otherwise -> + ((S.singleton (m,n),paramTypes gr t), + "type"<+>gId n<+>"="<+>convType gId t) _ -> ((S.empty,S.empty),empty) where - param (n,ctx) = gId n<+>[convertA gId gr t|(_,_,t)<-ctx] + param (n,ctx) = gId n<+>[convTypeA gId t|(_,_,t)<-ctx] argTypes = S.unions . map argTypes1 argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]