forked from GitHub/gf-core
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
This commit is contained in:
hallgren
@@ -27,7 +27,7 @@ concretes2haskell opts absname gr =
|
|||||||
]
|
]
|
||||||
|
|
||||||
concrete2haskell opts gr cenv absname cnc modinfo =
|
concrete2haskell opts gr cenv absname cnc modinfo =
|
||||||
render $
|
renderStyle style{lineLength=80,ribbonsPerLine=1} $
|
||||||
haskPreamble va absname cnc $$ "" $$
|
haskPreamble va absname cnc $$ "" $$
|
||||||
"--- Parameter types ---" $$
|
"--- Parameter types ---" $$
|
||||||
vcat (neededParamTypes S.empty (params defs)) $$ "" $$
|
vcat (neededParamTypes S.empty (params defs)) $$ "" $$
|
||||||
@@ -69,11 +69,12 @@ concrete2haskell opts gr cenv absname cnc modinfo =
|
|||||||
params1 (Nothing,(_,rhs)) = paramTypes gr rhs
|
params1 (Nothing,(_,rhs)) = paramTypes gr rhs
|
||||||
params1 (_,(_,rhs)) = tableTypes gr [rhs]
|
params1 (_,(_,rhs)) = tableTypes gr [rhs]
|
||||||
|
|
||||||
ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 4 (convType va gId rhs)
|
ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 2 (convType va gId rhs)
|
||||||
ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 4 (convert va gId gr rhs)
|
ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 2 (convert va gId' gr rhs)
|
||||||
|
|
||||||
gId :: Ident -> Doc
|
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
|
va = haskellOption opts HaskellVariants
|
||||||
pure = if va then brackets else pp
|
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 (x,(Just ty,rhs)) = (x,ty):env
|
||||||
extend env _ = env
|
extend env _ = env
|
||||||
|
|
||||||
convert va gId = convert' False va gId []
|
convert va gId gr t = pp (convert' va gId [] gr t)
|
||||||
convertA va gId = convert' True va gId []
|
|
||||||
|
|
||||||
convert' atomic va gId vs gr = if atomic then ppA else ppT
|
convert' va gId vs gr = ppT
|
||||||
where
|
where
|
||||||
ppT0 = convert' False False gId vs gr
|
ppT0 = convert' False gId vs gr
|
||||||
ppA0 = convert' True False gId vs gr
|
ppTv vs' = convert' va gId vs' gr
|
||||||
ppTv vs' = convert' atomic va gId vs' gr
|
|
||||||
|
|
||||||
ppT = ppT' False
|
ppT t =
|
||||||
ppT' loop t =
|
|
||||||
case t of
|
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
|
-- Abs b x t -> "\\"<+>x<+>"->"<+>ppT t
|
||||||
-- V ty ts -> hang "table" 4 (sep [list (enumAll ty),list ts])
|
-- V ty ts -> hang "table" 4 (sep [list (enumAll ty),list ts])
|
||||||
V ty ts -> pure (hang "table" 4 (dedup ts))
|
V ty ts -> pure (c "table" `Ap` dedup ts)
|
||||||
T (TTyped ty) cs -> pure (hang "\\case" 2 (vcat (map ppCase cs)))
|
T (TTyped ty) cs -> pure (LambdaCase (map ppCase cs))
|
||||||
S t p -> join (ap t p)
|
S t p -> join (ap (ppT t) (ppT p))
|
||||||
C t1 t2 -> hang (ppA t1<+>concat) 4 (ppA t2)
|
C t1 t2 -> concat (ppT t1) (ppT t2)
|
||||||
_ -> ppB' loop t
|
App f a -> ap (ppT f) (ppT a)
|
||||||
|
R r -> aps (ppT (rcon (map fst r))) (fields r)
|
||||||
ppCase (p,t) = hang (ppP p <+> "->") 4 (ppTv (patVars p++vs) t)
|
P t l -> ap (ppT (proj l)) (ppT 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
|
|
||||||
FV [] -> empty
|
FV [] -> empty
|
||||||
_ -> ppA' loop t
|
Vr x -> if x `elem` vs then pure (Var x) else Var x
|
||||||
|
Cn x -> pure (Var x)
|
||||||
ppA = ppA' False
|
Con c -> pure (Var (gId c))
|
||||||
|
Sort k -> pure (Var k)
|
||||||
ppA' True t = error $ "Missing case in convert': "++show t
|
EInt n -> pure (lit n)
|
||||||
ppA' loop t =
|
Q (m,n) -> if m==cPredef then pure (ppPredef n) else Var (qual m n)
|
||||||
case t of
|
QC (m,n) -> pure (Var (gId (qual m n)))
|
||||||
Vr x -> if x `elem` vs then pureA (pp x) else pp x
|
K s -> pure (token s)
|
||||||
Cn x -> pureA (pp x)
|
Empty -> pure (List [])
|
||||||
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 "[]")
|
|
||||||
FV ts@(_:_) -> variants ts
|
FV ts@(_:_) -> variants ts
|
||||||
Alts t' vs -> pureA (alts t' vs)
|
Alts t' vs -> pure (alts t' vs)
|
||||||
_ -> parens (ppT' True t)
|
|
||||||
|
ppCase (p,t) = (ppP p,ppTv (patVars p++vs) t)
|
||||||
|
|
||||||
ppPredef n =
|
ppPredef n =
|
||||||
case predef n of
|
case predef n of
|
||||||
Ok BIND -> brackets "BIND"
|
Ok BIND -> single (c "BIND")
|
||||||
Ok SOFT_BIND -> brackets "SOFT_BIND"
|
Ok SOFT_BIND -> single (c "SOFT_BIND")
|
||||||
Ok CAPIT -> brackets "CAPIT"
|
Ok CAPIT -> single (c "CAPIT")
|
||||||
_ -> pp n
|
_ -> Var n
|
||||||
|
|
||||||
|
ppAP = ppP
|
||||||
ppP p =
|
ppP p =
|
||||||
case p of
|
case p of
|
||||||
PC c ps -> gId c<+>fsep (map ppAP ps)
|
PC c ps -> ConP (gId c) (map ppAP ps)
|
||||||
PP (_,c) ps -> gId c<+>fsep (map ppAP ps)
|
PP (_,c) ps -> ConP (gId c) (map ppAP ps)
|
||||||
PR r -> rcon (map fst r)<+>fsep (map (ppAP.snd) (filter (not.isLockLabel.fst) r))
|
PR r -> ConP (rcon' (map fst r)) (map (ppAP.snd) (filter (not.isLockLabel.fst) r))
|
||||||
_ -> ppAP p
|
PW -> WildP
|
||||||
|
PV x -> VarP x
|
||||||
ppAP p =
|
PString s -> Lit (show s) -- !!
|
||||||
case p of
|
PInt i -> Lit (show i)
|
||||||
PW -> pp "_"
|
PFloat x -> Lit (show x)
|
||||||
PV x -> pp x
|
|
||||||
PString s -> doubleQuotes s
|
|
||||||
PInt i -> pp i
|
|
||||||
PFloat x -> pp x
|
|
||||||
PT _ p -> ppAP p
|
PT _ p -> ppAP p
|
||||||
PAs x p -> x<>"@"<>ppAP p
|
PAs x p -> AsP x (ppP p)
|
||||||
_ -> parens (ppAP 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
|
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 (Strs ts) = concatMap pre ts
|
||||||
pre (EPatt p) = pat p
|
pre (EPatt p) = pat p
|
||||||
pre t = error $ "pre "++show t
|
pre t = error $ "pre "++show t
|
||||||
|
|
||||||
pat (PString s) = [s]
|
pat (PString s) = [lit s]
|
||||||
pat (PAlt p1 p2) = pat p1++pat p2
|
pat (PAlt p1 p2) = pat p1++pat p2
|
||||||
pat p = error $ "pat "++show p
|
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 "++"
|
c = Const
|
||||||
-- pure = if va then \ x -> "pure"<+>parens x else id
|
single x = List [x]
|
||||||
-- pureA = if va then \ x -> parens ("pure"<+>x) else id
|
lit s = c (show s) -- hmm
|
||||||
pure = if va then \ x -> brackets x else id -- forcing the list monad
|
concat = if va then concat' else concat0
|
||||||
pureA = pure
|
where
|
||||||
ap = if va then \ f x -> hang (ppA f<+>"<*>") 4 (ppA x)
|
concat0 (List ts1) (List ts2) = List (ts2++ts2)
|
||||||
else \ f x -> hang (ppB f) 4 (ppA x)
|
concat0 t1 t2 =Op t1 "++" t2
|
||||||
join = if va then \ x -> parens ("concat"<+>parens x) else id
|
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
|
||||||
-- sequence = if va then \ x -> parens ("sequence"<+>parens x) else id
|
concat' t1 t2 = Op t1 "+++" t2
|
||||||
empty = if va then pp "[]" else "error"<+>doubleQuotes "empty variant"
|
pure = if va then pure' else id
|
||||||
variants = if va then \ ts -> "concat"<+>list ts
|
pure' x = List [x] -- forcing the list monad
|
||||||
else \ (t:_) -> "{-variants-}"<>ppA t -- !!
|
|
||||||
|
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 [] = 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
|
-- enumAll ty = case allParamValues gr ty of Ok ts -> ts
|
||||||
|
|
||||||
list = brackets . fsep . punctuate "," . map ppT
|
-- list = brackets . fsep . punctuate "," . map ppT
|
||||||
list' = brackets . fsep . punctuate ","
|
-- list' = brackets . fsep . punctuate ","
|
||||||
|
|
||||||
dedup ts =
|
dedup ts =
|
||||||
if M.null dups
|
if M.null dups
|
||||||
then list ts
|
then List (map ppT ts)
|
||||||
else parens $
|
else Lets [(ev i,ppT t)|(i,t)<-defs] (List (zipWith entry ts is))
|
||||||
"let"<+>vcat [ev i<+>"="<+>ppT t|(i,t)<-defs] $$
|
|
||||||
"in"<+>list' (zipWith entry ts is)
|
|
||||||
where
|
where
|
||||||
entry t i = maybe (ppT t) ev (M.lookup i dups)
|
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
|
||||||
ev i = "e'"<>i
|
ev i = identS ("e'"++show i)
|
||||||
|
|
||||||
defs = [(i1,t)|(t,i1:_:_)<-ms]
|
defs = [(i1,t)|(t,i1:_:_)<-ms]
|
||||||
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
|
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)
|
proj l = con ("proj_"++render l)
|
||||||
rcon = con . rcon_name
|
rcon = con . rcon_name
|
||||||
|
rcon' = identS . rcon_name
|
||||||
rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
|
rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
|
||||||
to_rcon = con . ("to_"++) . rcon_name
|
to_rcon = con . ("to_"++) . rcon_name
|
||||||
|
|
||||||
@@ -441,3 +433,50 @@ enumCon name arity =
|
|||||||
|
|
||||||
qual :: ModuleName -> Ident -> Ident
|
qual :: ModuleName -> Ident -> Ident
|
||||||
qual m = prefixIdent (render m++"_")
|
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
|
||||||
|
|||||||
Reference in New Issue
Block a user