forked from GitHub/gf-core
820d2d503f
* In GHC 8.4.1, the operator <> has become a method of the Semigroup class
and is exported from the Prelude. This is unfortunate, since <> is also
exported from the standard library module Text.PrettyPrint, so in any
module that defines a pretty printer, there is likely to be an ambiguity.
This affects ~18 modules in GF. Solution:
import Prelude hiding (<>)
This works also in older versions of GHC, since GHC does't complain if
you hide something that doesn't exists.
* In GHC 8.4.1, Semigroup has become a superclass of Monoid. This means
that anywhere you define an instance of the Monoid class you also have to
define an instance in the Semigroup class.
This affects Data.Binary.Builder in GF. Solution: conditionally define
a Semigroup instance if compiling with base>=4.11 (ghc>=8.4.1)
148 lines
4.1 KiB
Haskell
148 lines
4.1 KiB
Haskell
-- | Abstract syntax and a pretty printer for a subset of Haskell
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
module GF.Haskell where
|
|
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
|
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<>"@"<>ppA p
|
|
_ -> parens p
|