diff --git a/gf.cabal b/gf.cabal index 28184ec79..6ea3a8d4b 100644 --- a/gf.cabal +++ b/gf.cabal @@ -184,6 +184,7 @@ Library GF.Compile.Multi GF.Compile.Optimize GF.Compile.PGFtoHaskell + GF.Haskell GF.Compile.ConcreteToHaskell GF.Compile.PGFtoJS GF.Compile.PGFtoLProlog diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 0b55a959d..3dc71b3f5 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -17,6 +17,7 @@ import GF.Compile.Compute.Value(Predefined(..)) import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS import GF.Infra.Option import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) +import GF.Haskell import Debug.Trace -- | Generate Haskell code for the all concrete syntaxes associated with @@ -34,52 +35,55 @@ concretes2haskell opts absname gr = -- @-haskell=noprefix@ and @-haskell=variants@. concrete2haskell opts gr cenv absname cnc modinfo = renderStyle style{lineLength=80,ribbonsPerLine=1} $ - haskPreamble va absname cnc $$ "" $$ - "--- Parameter types ---" $$ - vcat (neededParamTypes S.empty (params defs)) $$ "" $$ - "--- Type signatures for linearization functions ---" $$ - vcat (map signature (S.toList allcats)) $$ "" $$ - "--- Linearization functions for empty categories ---" $$ - vcat emptydefs $$ "" $$ - "--- Linearization types and linearization functions ---" $$ - vcat (map ppDef defs) $$ "" $$ - "--- Type classes for projection functions ---" $$ - vcat (map labelClass (S.toList labels)) $$ "" $$ - "--- Record types ---" $$ - vcat (map recordType recs) + haskPreamble va absname cnc $$ vcat ( + nl:Comment "--- Parameter types ---": + neededParamTypes S.empty (params defs) ++ + nl:Comment "--- Type signatures for linearization functions ---": + map signature (S.toList allcats)++ + nl:Comment "--- Linearization functions for empty categories ---": + emptydefs ++ + nl:Comment "--- Linearization types and linearization functions ---": + map ppDef defs ++ + nl:Comment "--- Type classes for projection functions ---": + map labelClass (S.toList labels) ++ + nl:Comment "--- Record types ---": + concatMap recordType recs) where + nl = Comment "" labels = S.difference (S.unions (map S.fromList recs)) common_labels recs = S.toList (S.difference (records rhss) common_records) common_records = S.fromList [[label_s]] common_labels = S.fromList [label_s] label_s = ident2label (identS "s") - rhss = map (snd.snd) defs - defs = sortBy (compare `on` fst) . + rhss = map (either snd (snd.snd)) defs + defs = sortBy (compare `on` either (const Nothing) (Just . fst)) . concatMap (toHaskell gId gr absname cenv) . M.toList $ jments 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<+>"::"<+>Fun abs (pure lin) + signature c = TypeSig lf (Fun abs (pure lin)) where abs = tcon0 (prefixIdent "A." (gId c)) - lin = tcon0 (prefixIdent "Lin" c) + lin = tcon0 lc + lf = prefixIdent "lin" c + lc = prefixIdent "Lin" c emptydefs = map emptydef (S.toList emptyCats) - emptydef c = "lin"<>c<+>"_"<+>"="<+>"undefined" + emptydef c = Eqn (prefixIdent "lin" c,[WildP]) (Const "undefined") emptyCats = allcats `S.difference` cats - cats = S.fromList [c|(Just c,_)<-defs] + cats = S.fromList [c|Right (c,_)<-defs] allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname] - - params = S.toList . S.unions . map params1 - params1 (Nothing,(_,rhs)) = paramTypes gr rhs - 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) + params = S.toList . S.unions . map params1 + params1 (Left (_,rhs)) = paramTypes gr rhs + params1 (Right (_,(_,rhs))) = tableTypes gr [rhs] + + ppDef (Left (lhs,rhs)) = lhs (convType va gId rhs) + ppDef (Right (_,(lhs,rhs))) = lhs (convert va gId gr rhs) gId :: Ident -> Ident gId = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G" @@ -91,7 +95,7 @@ concrete2haskell opts gr cenv absname cnc modinfo = if q `S.member` have then neededParamTypes have qs else let ((got,need),def) = paramType va gId gr q - in def:neededParamTypes (S.union got have) (S.toList need++qs) + in def++neededParamTypes (S.union got have) (S.toList need++qs) haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc haskPreamble va absname cncname = @@ -116,10 +120,10 @@ haskPreamble va absname cncname = toHaskell gId gr absname cenv (name,jment) = case jment of CncCat (Just (L loc typ)) _ _ pprn _ -> - [(Nothing,("type"<+>"Lin"<>name,nf loc typ))] + [Left (tsyn0 (prefixIdent "Lin" name),nf loc typ)] CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> -- trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $ - [(Just cat,("lin"<>cat<+>lhs,coerce [] lincat rhs))] + [Right (cat,(Eqn (prefixIdent "lin" cat,lhs),coerce [] lincat rhs))] where Ok abstype = lookupFunType gr absname name (absctx,abscat,absargs) = typeForm abstype @@ -128,9 +132,8 @@ toHaskell gId gr absname cenv (name,jment) = 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 pp (aId name) - else parens (aId name<+>hsep abs_args) + abs_args = map (prefixIdent "abs_") args + lhs = [ConP (aId name) (map VarP 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))))) @@ -349,64 +352,72 @@ convType va gId = ppT fields = map (ppT.snd) . sort . filter (not.isLockLabel.fst) -proj l = con ("proj_"++render l) +proj = con . proj' +proj' l = "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 +to_rcon = con . to_rcon' +to_rcon' = ("to_"++) . rcon_name recordType ls = - "data"<+>app<+>"="<+>app <+> "deriving (Eq,Ord,Show)" $$ - enumAllInstance $$ - vcat (zipWith projection vs ls) $$ - hang (to_rcon ls<+>"r"<+>"=") 4 - (cn<+>fsep [parens (proj l<+>"r")|l<-ls]) $$ "" + Data lhs [app] ["Eq","Ord","Show"]: + enumAllInstance: + zipWith projection vs ls ++ + [Eqn (identS (to_rcon' ls),[VarP r]) + (foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])] where - cn = rcon ls - cn' = rcon' ls + r = identS "r" + 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]] + lhs = ConAp cn vs -- don't reuse record labels + app = fmap TId lhs + tapp = foldl TAp (TId cn) (map TId vs) + vs = [identS ('t':show i)|i<-[1..n]] n = length ls - projection v l = - hang ("instance"<+>"Has_"<>l<+>parens app<+>v<+>"where") 4 - (proj l<+>parens app<+>"="<+>v) + projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v) + [((prj,[papp]),Var v)] + where + name = identS ("Has_"++render l) + prj = identS (proj' l) + papp = ConP cn (map VarP vs) enumAllInstance = - hang ("instance"<+>ctx<+>"EnumAll"<+>parens app<+>"where") 4 - (hang ("enumAll"<+>"=") 4 (enumCon cn' n)) + Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)] where - ctx = if n==0 - then empty - else parens (fsep (punctuate "," ["EnumAll"<+>v|v<-vs]))<+>"=>" + ctx = [tEnumAll `TAp` TId v|v<-vs] + tEnumAll = TId (identS "EnumAll") labelClass l = - hang ("class"<+>"Has_"<>l<+>"r"<+>"a"<+>"| r -> a"<+>"where") 4 - (proj l<+>"::"<+>"r -> a") + Class [] (ConAp name [r,a]) [([r],[a])] + [(identS (proj' l),TId r `Fun` TId a)] + where + name = identS ("Has_"++render l) + r = identS "r" + a = identS "a" paramType va gId gr q@(_,n) = case lookupOrigInfo gr q of Ok (m,ResParam (Just (L _ ps)) _) {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> ((S.singleton (m,n),argTypes ps), - 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"<+>"="<+>foldr1 plusplus (map (enumParam m) ps)) + [Data (conap0 name) (map (param m) ps)["Eq","Ord","Show"], + Instance [] (TId (identS "EnumAll") `TAp` TId name) + [(lhs0 "enumAll",foldr1 plusplus (map (enumParam m) ps))]] ) + where name = gId (qual m n) Ok (m,ResOper _ (Just (L _ t))) | m==cPredef && n==cInts -> ((S.singleton (m,n),S.empty), - "type"<+>gId (qual m n)<+>"n = Int") + [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))]) | otherwise -> ((S.singleton (m,n),paramTypes gr t), - "type"<+>gId (qual m n)<+>"="<+>convType va gId t) - _ -> ((S.empty,S.empty),empty) + [Type (conap0 (gId (qual m n))) (convType va gId t)]) + _ -> ((S.empty,S.empty),[]) where - param m (n,ctx) = tcon (gId (qual m n)) [convType va gId t|(_,_,t)<-ctx] + param m (n,ctx) = ConAp (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] @@ -422,82 +433,3 @@ enumCon name arity = qual :: ModuleName -> Ident -> Ident 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 - 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 flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as)) - - 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 - - flatAp (Ap t1 t2) = flatAp t1++[t2] -- left associative - flatAp t = [t] - -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 diff --git a/src/compiler/GF/Haskell.hs b/src/compiler/GF/Haskell.hs new file mode 100644 index 000000000..55613c95c --- /dev/null +++ b/src/compiler/GF/Haskell.hs @@ -0,0 +1,146 @@ +-- | Abstract syntax and a pretty printer for a subset of Haskell +{-# LANGUAGE DeriveFunctor #-} +module GF.Haskell where +import GF.Infra.Ident(Ident,identS) +import GF.Text.Pretty + +-- | Top-level declarations +data Dec = Comment String + | Type (ConAp Ident) Ty + | Data (ConAp Ident) [ConAp Ty] Deriving + | Class [ConAp Ident] (ConAp Ident) FunDeps [(Ident,Ty)] + | Instance [Ty] Ty [(Lhs,Exp)] + | TypeSig Ident Ty + | Eqn Lhs Exp + +-- | A type constructor applied to some arguments +data ConAp a = ConAp Ident [a] deriving Functor +conap0 n = ConAp n [] +tsyn0 = Type . conap0 + +type Deriving = [Const] +type FunDeps = [([Ident],[Ident])] +type Lhs = (Ident,[Pat]) +lhs0 s = (identS s,[]) + +-- | Type expressions +data Ty = TId Ident | TAp Ty Ty | Fun Ty Ty | ListT Ty + +-- | Expressions +data Exp = Var Ident | Const Const | Ap Exp Exp | Op Exp Const Exp + | List [Exp] | Pair Exp Exp + | Lets [(Ident,Exp)] Exp | LambdaCase [(Pat,Exp)] +type Const = String + +-- | Patterns +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 + +-- | Pretty print atomically (i.e. wrap it in parentheses if necessary) +class Pretty a => PPA a where ppA :: a -> Doc + +instance PPA Ident where ppA = pp + +instance Pretty Dec where + ppList = vcat + pp d = + case d of + Comment s -> pp s + Type lhs rhs -> hang ("type"<+>lhs<+>"=") 4 rhs + Data lhs cons ds -> + hang ("data"<+>lhs) 4 + (sep (zipWith (<+>) ("=":repeat "|") cons++ + ["deriving"<+>parens (punctuate "," ds)|not (null ds)])) + Class ctx cls fds sigs -> + hang ("class"<+>sep [ppctx ctx,pp cls]<+>ppfds fds <+>"where") 4 + (vcat (map ppSig sigs)) + Instance ctx inst eqns -> + hang ("instance"<+>sep [ppctx ctx,pp inst]<+>"where") 4 + (vcat (map ppEqn eqns)) + TypeSig f ty -> hang (f<+>"::") 4 ty + Eqn lhs rhs -> ppEqn (lhs,rhs) + where + ppctx ctx = case ctx of + [] -> empty + [p] -> p <+> "=>" + ps -> parens (fsep (punctuate "," ps)) <+> "=>" + + ppfds [] = empty + ppfds fds = "|"<+>fsep (punctuate "," [hsep as<+>"->"<+>bs|(as,bs)<-fds]) + + ppEqn ((f,ps),e) = hang (f<+>fsep (map ppA ps)<+>"=") 4 e + + ppSig (f,ty) = f<+>"::"<+>ty + +instance PPA a => Pretty (ConAp a) where + pp (ConAp c as) = c<+>fsep (map ppA as) + +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) + + 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 PPA Ty where + ppA t = + case t of + TId c -> pp c + ListT t -> brackets t + _ -> parens t + +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 flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as)) + + flatAp (Ap t1 t2) = flatAp t1++[t2] -- left associative + flatAp t = [t] + +instance PPA Exp where + 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 p = + case p of + ConP c ps -> c<+>fsep (map ppA ps) + _ -> ppA p + +instance PPA Pat where + ppA p = + case p of + WildP -> pp "_" + VarP x -> pp x + Lit s -> pp s + ConP c [] -> pp c + AsP x p -> x<>"@"<>parens p + _ -> parens p