diff options
| -rw-r--r-- | src/compiler/GF/Compile/ConcreteToHaskell.hs | 225 |
1 files changed, 132 insertions, 93 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) - - 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 -- !! + fields = map (ppT.snd.snd) . sort . filter (not.isLockLabel.fst) + + 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 |