From 43a873b53fe8ed658ac7921366fec38e8a110b56 Mon Sep 17 00:00:00 2001 From: hallgren Date: Thu, 12 Feb 2015 16:05:48 +0000 Subject: [PATCH] Translating linearization functions to Haskell: more simplifications + Some additional simplifying rewrites. + Use an intermediate representation for Haskell types, for separation of concerns and cleaner code. + Pretty printer layout tuning + Code cleanup. --- src/compiler/GF/Compile/ConcreteToHaskell.hs | 179 ++++++++++--------- 1 file changed, 97 insertions(+), 82 deletions(-) diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index f2617b629..f25246bd3 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -56,7 +56,10 @@ concrete2haskell opts gr cenv absname cnc modinfo = -- signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c -- signature c = "--lin"<>c<+>":: (Applicative f,Monad f) =>"<+>"A."<>gId c<+>"->"<+>"f Lin"<>c - signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>pure ("Lin"<>c) + signature c = "lin"<>c<+>"::"<+>Fun abs (pure lin) + where + abs = tcon0 (prefixIdent "A." (gId c)) + lin = tcon0 (prefixIdent "Lin" c) emptydefs = map emptydef (S.toList emptyCats) emptydef c = "lin"<>c<+>"_"<+>"="<+>"undefined" @@ -70,13 +73,12 @@ concrete2haskell opts gr cenv absname cnc modinfo = params1 (_,(_,rhs)) = tableTypes gr [rhs] ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 2 (convType va gId rhs) - ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 2 (convert va gId' gr 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 id else prefixIdent "G" + gId :: Ident -> Ident + gId = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G" va = haskellOption opts HaskellVariants - pure = if va then brackets else pp + pure = if va then ListT else id neededParamTypes have [] = [] neededParamTypes have (q:qs) = @@ -90,11 +92,7 @@ haskPreamble va absname cncname = "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$ "module" <+> cncname <+> "where" $$ "import Prelude hiding (Ordering(..))" $$ - "import Control.Applicative(Applicative,pure,empty,(<$>),(<*>))" $$ ---"import Data.Foldable(asum)" $$ ---"import Control.Monad(join)" $$ - "import qualified Data.Map as M" $$ - "import Data.Map((!))" $$ + "import Control.Applicative((<$>),(<*>))" $$ "import PGF.Haskell" $$ "import qualified" <+> absname <+> "as A" $$ "" $$ @@ -125,7 +123,8 @@ toHaskell gId gr absname cenv (name,jment) = 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) + lhs = if null args then pp (aId name) + else parens (aId name<+>hsep abs_args) rhs = foldr letlin e' (zip args absctx) letlin (a,(_,_,at)) = Let (a,(Just (con ("Lin"++render at)),(App (con ("lin"++render at)) (con ("abs_"++render a))))) @@ -135,7 +134,7 @@ toHaskell gId gr absname cenv (name,jment) = _ -> [] where nf loc = normalForm cenv (L loc name) - aId n = "A."<>gId n + aId n = prefixIdent "A." (gId n) unAbs 0 t = t unAbs n (Abs _ _ t) = unAbs (n-1) t @@ -204,7 +203,7 @@ coerce env ty t = extend env (x,(Just ty,rhs)) = (x,ty):env extend env _ = env -convert va gId gr t = pp (convert' va gId [] gr t) +convert va gId gr = convert' va gId [] gr convert' va gId vs gr = ppT where @@ -213,13 +212,12 @@ convert' va gId vs gr = ppT ppT t = case t of - -- For lets inserted on the top-level by this converter: + -- Only for 'let' 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]) +-- Abs b x 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)) + S t p -> select (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) @@ -246,18 +244,17 @@ convert' va gId vs gr = ppT Ok CAPIT -> single (c "CAPIT") _ -> Var n - ppAP = ppP ppP p = case p of - 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)) + PC c ps -> ConP (gId c) (map ppP ps) + PP (_,c) ps -> ConP (gId c) (map ppP ps) + PR r -> ConP (rcon' (map fst r)) (map (ppP.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 + PT _ p -> ppP p PAs x p -> AsP x (ppP p) token s = single (c "TK" `Ap` lit s) @@ -278,16 +275,18 @@ convert' va gId vs gr = ppT 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 + concat = if va then concat' else plusplus 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 + pure = if va then single else id + pure' = single -- forcing the list monad + + select = if va then select' else Ap + select' (List [t]) (List [p]) = Op t "!" p + select' (List [t]) p = Op t "!$" p + select' t p = Op t "!*" p ap = if va then ap' else Ap where @@ -295,22 +294,18 @@ convert' va gId vs gr = ppT 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 + +-- join = if va then join' else id + 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) + variants = if va then \ ts -> join' (List (map ppT ts)) else \ (t:_) -> ppT t aps f [] = f 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 "," - dedup ts = if M.null dups then List (map ppT ts) @@ -331,38 +326,22 @@ patVars p = PAs x p -> x:patVars p _ -> collectPattOp patVars p -convType = convType' False -convTypeA = convType' True - -convType' atomic va gId = if atomic then ppA else ppT +convType va gId = ppT where - ppT = ppT' False - ppT' loop t = + ppT t = case t of - Table ti tv -> ppB ti <+> "->" <+> - if va then brackets (ppT tv) else ppT tv - _ -> ppB' loop t + Table ti tv -> Fun (ppT ti) (if va then ListT (ppT tv) else ppT tv) + RecType rt -> tcon (rcon' (map fst rt)) (fields rt) + App tf ta -> TAp (ppT tf) (ppT ta) + FV [] -> tcon0 (identS "({-empty variant-})") + Sort k -> tcon0 k + EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal + FV (t:ts) -> ppT t -- !! + QC (m,n) -> tcon0 (gId (qual m n)) + Q (m,n) -> tcon0 (gId (qual m n)) + _ -> error $ "Missing case in convType for: "++show t - ppB = ppB' False - ppB' loop t = - case t of - RecType rt -> rcon (map fst rt)<+>fsep (fields rt) - App tf ta -> ppB tf <+> ppA ta - FV [] -> pp "({-empty variant-})" - _ -> ppA' loop 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 (qual m n) - Q (m,n) -> gId (qual m n) - _ -> {-trace (show t) $-} parens (ppT' True t) - - fields = map (ppA.snd) . sort . filter (not.isLockLabel.fst) + fields = map (ppT.snd) . sort . filter (not.isLockLabel.fst) proj l = con ("proj_"++render l) rcon = con . rcon_name @@ -374,9 +353,11 @@ recordType ls = "data"<+>app<+>"="<+>app <+> "deriving (Eq,Ord,Show)" $$ enumAllInstance $$ vcat (zipWith projection vs ls) $$ - to_rcon ls<+>"r"<+>"="<+>cn<+>fsep [parens (proj l<+>"r")|l<-ls] $$ "" + hang (to_rcon ls<+>"r"<+>"=") 4 + (cn<+>fsep [parens (proj l<+>"r")|l<-ls]) $$ "" where cn = rcon 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 @@ -389,7 +370,7 @@ recordType ls = enumAllInstance = hang ("instance"<+>ctx<+>"EnumAll"<+>parens app<+>"where") 4 - ("enumAll"<+>"="<+>enumCon cn n) + (hang ("enumAll"<+>"=") 4 (enumCon cn' n)) where ctx = if n==0 then empty @@ -404,11 +385,11 @@ paramType va gId gr q@(_,n) = Ok (m,ResParam (Just (L _ ps)) _) {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> ((S.singleton (m,n),argTypes ps), - "data"<+>gId (qual m n)<+>"="<+> - sep [fsep (punctuate " |" (map (param m) ps)), - pp "deriving (Eq,Ord,Show)"] $$ + hang ("data"<+>gId (qual m n)<+>"=") 7 + (sep [fsep (punctuate " |" (map (param m) ps)), + pp "deriving (Eq,Ord,Show)"]) $$ hang ("instance EnumAll"<+>gId (qual m n)<+>"where") 4 - ("enumAll"<+>"="<+>sep (punctuate " ++" (map (enumParam m) ps))) + ("enumAll"<+>"="<+>foldr1 plusplus (map (enumParam m) ps)) ) Ok (m,ResOper _ (Just (L _ t))) | m==cPredef && n==cInts -> @@ -419,7 +400,7 @@ paramType va gId gr q@(_,n) = "type"<+>gId (qual m n)<+>"="<+>convType va gId t) _ -> ((S.empty,S.empty),empty) where - param m (n,ctx) = gId (qual m n)<+>[convTypeA va gId t|(_,_,t)<-ctx] + param m (n,ctx) = tcon (gId (qual m n)) [convType va gId t|(_,_,t)<-ctx] argTypes = S.unions . map argTypes1 argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] @@ -427,9 +408,11 @@ paramType va gId gr q@(_,n) = enumCon name arity = if arity==0 - then brackets name - else parens $ - fsep ((name<+>"<$>"):punctuate " <*>" (replicate arity (pp "enumAll"))) + then single (Var name) + else foldl ap (single (Var name)) (replicate arity (Const "enumAll")) + where + ap (List [f]) a = Op f "<$>" a + ap f a = Op f "<*>" a qual :: ModuleName -> Ident -> Ident qual m = prefixIdent (render m++"_") @@ -437,12 +420,42 @@ qual m = prefixIdent (render m++"_") -------------------------------------------------------------------------------- -- ** A Haskell subset +data Ty = TId Ident | TAp Ty Ty | Fun Ty Ty | ListT Ty + 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 +tvar = TId +tcon0 = TId +tcon c = foldl TAp (TId c) + let1 x xe e = Lets [(x,xe)] e +single x = List [x] + +plusplus (List ts1) (List ts2) = List (ts1++ts2) +plusplus (List [t]) t2 = Op t ":" t2 +plusplus t1 t2 = Op t1 "++" t2 + +instance Pretty Ty where + pp = ppT + where + ppT t = case flatFun t of t:ts -> sep (ppB t:["->"<+>ppB t|t<-ts]) + ppB t = case flatTAp t of t:ts -> ppA t<+>sep (map ppA ts) + + ppA t = + case t of + TId c -> pp c + ListT t -> brackets t + _ -> parens t + + flatFun (Fun t1 t2) = t1:flatFun t2 -- right associative + flatFun t = [t] + + flatTAp (TAp t1 t2) = flatTAp t1++[t2] -- left associative + flatTAp t = [t] instance Pretty Exp where pp = ppT @@ -454,10 +467,9 @@ instance Pretty Exp where "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 + + ppB e = case flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as)) + ppA e = case e of Var x -> pp x @@ -466,6 +478,9 @@ instance Pretty Exp where List es -> brackets (fsep (punctuate "," es)) _ -> parens e + flatAp (Ap t1 t2) = flatAp t1++[t2] -- left associative + flatAp t = [t] + instance Pretty Pat where pp = ppP where