From 686f570660b79970ab4583d4c810f086e3ed120c Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 11 Feb 2015 23:50:19 +0000 Subject: [PATCH] Translating linearization functions to Haskell: simplify the generated Haskell code Introduced an intermediate representation for the generated Haskell expressions. This allows pretty printing concerns to be separated from conversion concerns, and makes it easy to apply some simplifying rewrites to the generated expressions, e.g. [x] ++ [y] ==> [x,y] pure f <*> x ==> f <$> x f <$> pure x ==> pure (f x) join (pure x) ==> x --- src/compiler/GF/Compile/ConcreteToHaskell.hs | 223 +++++++++++-------- 1 file changed, 131 insertions(+), 92 deletions(-) diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 50c151f75..f2617b629 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -27,7 +27,7 @@ concretes2haskell opts absname gr = ] concrete2haskell opts gr cenv absname cnc modinfo = - render $ + renderStyle style{lineLength=80,ribbonsPerLine=1} $ haskPreamble va absname cnc $$ "" $$ "--- Parameter types ---" $$ vcat (neededParamTypes S.empty (params defs)) $$ "" $$ @@ -69,11 +69,12 @@ concrete2haskell opts gr cenv absname cnc modinfo = params1 (Nothing,(_,rhs)) = paramTypes gr rhs params1 (_,(_,rhs)) = tableTypes gr [rhs] - ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 4 (convType va gId rhs) - ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 4 (convert va gId gr rhs) + ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 2 (convType va gId rhs) + ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 2 (convert va gId' gr rhs) gId :: Ident -> Doc - gId = if haskellOption opts HaskellNoPrefix then pp else ("G"<>).pp + gId = if haskellOption opts HaskellNoPrefix then pp else ("G"<>).pp + gId' = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G" va = haskellOption opts HaskellVariants pure = if va then brackets else pp @@ -203,130 +204,120 @@ coerce env ty t = extend env (x,(Just ty,rhs)) = (x,ty):env extend env _ = env -convert va gId = convert' False va gId [] -convertA va gId = convert' True va gId [] +convert va gId gr t = pp (convert' va gId [] gr t) -convert' atomic va gId vs gr = if atomic then ppA else ppT +convert' va gId vs gr = ppT where - ppT0 = convert' False False gId vs gr - ppA0 = convert' True False gId vs gr - ppTv vs' = convert' atomic va gId vs' gr + ppT0 = convert' False gId vs gr + ppTv vs' = convert' va gId vs' gr - ppT = ppT' False - ppT' loop t = + ppT t = case t of - Let (x,(_,xt)) t -> sep ["let"<+>x<+>"="<+>ppT0 xt,"in"<+>ppT t] + -- For lets inserted on the top-level by this converter: + Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t) -- Abs b x t -> "\\"<+>x<+>"->"<+>ppT t -- V ty ts -> hang "table" 4 (sep [list (enumAll ty),list ts]) - V ty ts -> pure (hang "table" 4 (dedup ts)) - T (TTyped ty) cs -> pure (hang "\\case" 2 (vcat (map ppCase cs))) - S t p -> join (ap t p) - C t1 t2 -> hang (ppA t1<+>concat) 4 (ppA t2) - _ -> ppB' loop t - - ppCase (p,t) = hang (ppP p <+> "->") 4 (ppTv (patVars p++vs) t) - - ppB = ppB' False - ppB' loop t = - case t of - App f a -> ap f a - R r -> aps (ppA (rcon (map fst r))) (fields r) - P t l -> ap (proj l) t + V ty ts -> pure (c "table" `Ap` dedup ts) + T (TTyped ty) cs -> pure (LambdaCase (map ppCase cs)) + S t p -> join (ap (ppT t) (ppT p)) + C t1 t2 -> concat (ppT t1) (ppT t2) + App f a -> ap (ppT f) (ppT a) + R r -> aps (ppT (rcon (map fst r))) (fields r) + P t l -> ap (ppT (proj l)) (ppT t) FV [] -> empty - _ -> ppA' loop t - - ppA = ppA' False - - ppA' True t = error $ "Missing case in convert': "++show t - ppA' loop t = - case t of - Vr x -> if x `elem` vs then pureA (pp x) else pp x - Cn x -> pureA (pp x) - Con c -> pureA (gId c) - Sort k -> pureA (pp k) - EInt n -> pureA (pp n) - Q (m,n) -> if m==cPredef - then pureA (ppPredef n) - else pp (qual m n) - QC (m,n) -> pureA (gId (qual m n)) - K s -> pureA (token s) - Empty -> pureA (pp "[]") + Vr x -> if x `elem` vs then pure (Var x) else Var x + Cn x -> pure (Var x) + Con c -> pure (Var (gId c)) + Sort k -> pure (Var k) + EInt n -> pure (lit n) + Q (m,n) -> if m==cPredef then pure (ppPredef n) else Var (qual m n) + QC (m,n) -> pure (Var (gId (qual m n))) + K s -> pure (token s) + Empty -> pure (List []) FV ts@(_:_) -> variants ts - Alts t' vs -> pureA (alts t' vs) - _ -> parens (ppT' True t) + Alts t' vs -> pure (alts t' vs) + + ppCase (p,t) = (ppP p,ppTv (patVars p++vs) t) ppPredef n = case predef n of - Ok BIND -> brackets "BIND" - Ok SOFT_BIND -> brackets "SOFT_BIND" - Ok CAPIT -> brackets "CAPIT" - _ -> pp n + Ok BIND -> single (c "BIND") + Ok SOFT_BIND -> single (c "SOFT_BIND") + Ok CAPIT -> single (c "CAPIT") + _ -> Var n + ppAP = ppP ppP p = case p of - PC c ps -> gId c<+>fsep (map ppAP ps) - PP (_,c) ps -> gId c<+>fsep (map ppAP ps) - PR r -> rcon (map fst r)<+>fsep (map (ppAP.snd) (filter (not.isLockLabel.fst) r)) - _ -> ppAP p - - ppAP p = - case p of - PW -> pp "_" - PV x -> pp x - PString s -> doubleQuotes s - PInt i -> pp i - PFloat x -> pp x + PC c ps -> ConP (gId c) (map ppAP ps) + PP (_,c) ps -> ConP (gId c) (map ppAP ps) + PR r -> ConP (rcon' (map fst r)) (map (ppAP.snd) (filter (not.isLockLabel.fst) r)) + PW -> WildP + PV x -> VarP x + PString s -> Lit (show s) -- !! + PInt i -> Lit (show i) + PFloat x -> Lit (show x) PT _ p -> ppAP p - PAs x p -> x<>"@"<>ppAP p - _ -> parens (ppAP p) + PAs x p -> AsP x (ppP p) - token s = brackets ("TK"<+>doubleQuotes s) + token s = single (c "TK" `Ap` lit s) - alts t' vs = brackets ("TP" <+> list' (map alt vs) <+> ppA0 t') + alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t') where - alt (t,p) = parens (show (pre p)<>","<>ppT0 t) + alt (t,p) = Pair (List (pre p)) (ppT0 t) - pre (K s) = [s] + pre (K s) = [lit s] pre (Strs ts) = concatMap pre ts pre (EPatt p) = pat p pre t = error $ "pre "++show t - pat (PString s) = [s] + pat (PString s) = [lit s] pat (PAlt p1 p2) = pat p1++pat p2 pat p = error $ "pat "++show p - fields = map (ppA.snd.snd) . sort . filter (not.isLockLabel.fst) + fields = map (ppT.snd.snd) . sort . filter (not.isLockLabel.fst) - concat = if va then "+++" else "++" --- pure = if va then \ x -> "pure"<+>parens x else id --- pureA = if va then \ x -> parens ("pure"<+>x) else id - pure = if va then \ x -> brackets x else id -- forcing the list monad - pureA = pure - ap = if va then \ f x -> hang (ppA f<+>"<*>") 4 (ppA x) - else \ f x -> hang (ppB f) 4 (ppA x) - join = if va then \ x -> parens ("concat"<+>parens x) else id --- sequence = if va then \ x -> parens ("sequence"<+>parens x) else id - empty = if va then pp "[]" else "error"<+>doubleQuotes "empty variant" - variants = if va then \ ts -> "concat"<+>list ts - else \ (t:_) -> "{-variants-}"<>ppA t -- !! + c = Const + single x = List [x] + lit s = c (show s) -- hmm + concat = if va then concat' else concat0 + where + concat0 (List ts1) (List ts2) = List (ts2++ts2) + concat0 t1 t2 =Op t1 "++" t2 + concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)] + concat' t1 t2 = Op t1 "+++" t2 + pure = if va then pure' else id + pure' x = List [x] -- forcing the list monad + + ap = if va then ap' else Ap + where + ap' (List [f]) x = fmap f x + ap' f x = Op f "<*>" x + fmap f (List [x]) = pure' (Ap f x) + fmap f x = Op f "<$>" x + join = if va then join' else id + where + join' (List [x]) = x + join' x = c "concat" `Ap` x + empty = if va then List [] else c "error" `Ap` c (show "empty variant") + variants = if va then \ ts -> c "concat" `Ap` List (map ppT ts) + else \ (t:_) -> ppT t aps f [] = f - aps f (a:as) = aps (if va then hang (f<+>"<*>") 4 a else hang f 4 a) as + aps f (a:as) = aps (ap f a) as -- enumAll ty = case allParamValues gr ty of Ok ts -> ts - list = brackets . fsep . punctuate "," . map ppT - list' = brackets . fsep . punctuate "," +-- list = brackets . fsep . punctuate "," . map ppT +-- list' = brackets . fsep . punctuate "," dedup ts = if M.null dups - then list ts - else parens $ - "let"<+>vcat [ev i<+>"="<+>ppT t|(i,t)<-defs] $$ - "in"<+>list' (zipWith entry ts is) + then List (map ppT ts) + else Lets [(ev i,ppT t)|(i,t)<-defs] (List (zipWith entry ts is)) where - entry t i = maybe (ppT t) ev (M.lookup i dups) - ev i = "e'"<>i + entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups) + ev i = identS ("e'"++show i) defs = [(i1,t)|(t,i1:_:_)<-ms] dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is] @@ -375,6 +366,7 @@ convType' atomic va gId = if atomic then ppA else ppT proj l = con ("proj_"++render l) rcon = con . rcon_name +rcon' = identS . rcon_name rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)]) to_rcon = con . ("to_"++) . rcon_name @@ -441,3 +433,50 @@ enumCon name arity = qual :: ModuleName -> Ident -> Ident qual m = prefixIdent (render m++"_") + +-------------------------------------------------------------------------------- +-- ** A Haskell subset + +data Exp = Var Ident | Const String | Ap Exp Exp | Op Exp String Exp + | List [Exp] | Pair Exp Exp + | Lets [(Ident,Exp)] Exp | LambdaCase [(Pat,Exp)] +data Pat = WildP | VarP Ident | Lit String | ConP Ident [Pat] | AsP Ident Pat + +let1 x xe e = Lets [(x,xe)] e + +instance Pretty Exp where + pp = ppT + where + ppT e = + case e of + Op e1 op e2 -> hang (ppB e1<+>op) 2 (ppB e2) + Lets bs e -> sep ["let"<+>vcat [hang (x<+>"=") 2 xe|(x,xe)<-bs], + "in" <+>e] + LambdaCase alts -> hang "\\case" 4 (vcat [p<+>"->"<+>e|(p,e)<-alts]) + _ -> ppB e + ppB e = + case e of + Ap f a -> hang (ppB f) 2 (ppA a) + _ -> ppA e + ppA e = + case e of + Var x -> pp x + Const n -> pp n + Pair e1 e2 -> parens (e1<>","<>e2) + List es -> brackets (fsep (punctuate "," es)) + _ -> parens e + +instance Pretty Pat where + pp = ppP + where + ppP p = + case p of + ConP c ps -> c<+>fsep (map ppPA ps) + _ -> ppPA p + ppPA p = + case p of + WildP -> pp "_" + VarP x -> pp x + Lit s -> pp s + AsP x p -> x<>"@"<>parens p + _ -> parens p