summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GF/Compile/ConcreteToHaskell.hs210
-rw-r--r--src/compiler/GF/Haskell.hs146
2 files changed, 217 insertions, 139 deletions
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]
+ params1 (Left (_,rhs)) = paramTypes gr rhs
+ params1 (Right (_,(_,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 (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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:18:20 +0000