{-# LANGUAGE DeriveFunctor #-}
module GF.Haskell where
import Prelude hiding ((<>))
import GF.Infra.Ident(Ident,identS)
import GF.Text.Pretty
data Dec = 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
data ConAp a = ConAp Ident [a] deriving a -> ConAp b -> ConAp a
(a -> b) -> ConAp a -> ConAp b
(forall a b. (a -> b) -> ConAp a -> ConAp b)
-> (forall a b. a -> ConAp b -> ConAp a) -> Functor ConAp
forall a b. a -> ConAp b -> ConAp a
forall a b. (a -> b) -> ConAp a -> ConAp b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ConAp b -> ConAp a
$c<$ :: forall a b. a -> ConAp b -> ConAp a
fmap :: (a -> b) -> ConAp a -> ConAp b
$cfmap :: forall a b. (a -> b) -> ConAp a -> ConAp b
Functor
conap0 :: Ident -> ConAp a
conap0 Ident
n = Ident -> [a] -> ConAp a
forall a. Ident -> [a] -> ConAp a
ConAp Ident
n []
tsyn0 :: Ident -> Ty -> Dec
tsyn0 = ConAp Ident -> Ty -> Dec
Type (ConAp Ident -> Ty -> Dec)
-> (Ident -> ConAp Ident) -> Ident -> Ty -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ConAp Ident
forall a. Ident -> ConAp a
conap0
type Deriving = [Const]
type FunDeps = [([Ident],[Ident])]
type Lhs = (Ident,[Pat])
lhs0 :: String -> (Ident, [a])
lhs0 String
s = (String -> Ident
identS String
s,[])
data Ty = TId Ident | TAp Ty Ty | Fun Ty Ty | ListT Ty
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
data Pat = WildP | VarP Ident | Lit String | ConP Ident [Pat] | AsP Ident Pat
tvar :: Ident -> Ty
tvar = Ident -> Ty
TId
tcon0 :: Ident -> Ty
tcon0 = Ident -> Ty
TId
tcon :: Ident -> t Ty -> Ty
tcon Ident
c = (Ty -> Ty -> Ty) -> Ty -> t Ty -> Ty
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Ty -> Ty -> Ty
TAp (Ident -> Ty
TId Ident
c)
lets :: [(Ident, Exp)] -> Exp -> Exp
lets [] Exp
e = Exp
e
lets [(Ident, Exp)]
ds Exp
e = [(Ident, Exp)] -> Exp -> Exp
Lets [(Ident, Exp)]
ds Exp
e
let1 :: Ident -> Exp -> Exp -> Exp
let1 Ident
x Exp
xe Exp
e = [(Ident, Exp)] -> Exp -> Exp
Lets [(Ident
x,Exp
xe)] Exp
e
single :: Exp -> Exp
single Exp
x = [Exp] -> Exp
List [Exp
x]
plusplus :: Exp -> Exp -> Exp
plusplus (List [Exp]
ts1) (List [Exp]
ts2) = [Exp] -> Exp
List ([Exp]
ts1[Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++[Exp]
ts2)
plusplus (List [Exp
t]) Exp
t2 = Exp -> String -> Exp -> Exp
Op Exp
t String
":" Exp
t2
plusplus Exp
t1 Exp
t2 = Exp -> String -> Exp -> Exp
Op Exp
t1 String
"++" Exp
t2
class Pretty a => PPA a where ppA :: a -> Doc
instance PPA Ident where ppA :: Ident -> Doc
ppA = Ident -> Doc
forall a. Pretty a => a -> Doc
pp
instance Pretty Dec where
ppList :: [Dec] -> Doc
ppList = [Dec] -> Doc
forall a. Pretty a => [a] -> Doc
vcat
pp :: Dec -> Doc
pp Dec
d =
case Dec
d of
Comment String
s -> String -> Doc
forall a. Pretty a => a -> Doc
pp String
s
Type ConAp Ident
lhs Ty
rhs -> Doc -> Int -> Ty -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (String
"type"String -> ConAp Ident -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>ConAp Ident
lhsDoc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"=") Int
4 Ty
rhs
Data ConAp Ident
lhs [ConAp Ty]
cons Deriving
ds ->
Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (String
"data"String -> ConAp Ident -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>ConAp Ident
lhs) Int
4
([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep ((String -> ConAp Ty -> Doc) -> Deriving -> [ConAp Ty] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> ConAp Ty -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
(<+>) (String
"="String -> Deriving -> Deriving
forall a. a -> [a] -> [a]
:String -> Deriving
forall a. a -> [a]
repeat String
"|") [ConAp Ty]
cons[Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
[String
"deriving"String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => a -> Doc
parens (String -> Deriving -> [Doc]
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> [a2] -> [Doc]
punctuate String
"," Deriving
ds)|Bool -> Bool
not (Deriving -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Deriving
ds)]))
Class [ConAp Ident]
ctx ConAp Ident
cls FunDeps
fds [(Ident, Ty)]
sigs ->
Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (String
"class"String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep [[ConAp Ident] -> Doc
forall a. Pretty a => [a] -> Doc
ppctx [ConAp Ident]
ctx,ConAp Ident -> Doc
forall a. Pretty a => a -> Doc
pp ConAp Ident
cls]Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FunDeps -> Doc
forall a2 a. (Pretty a2, Pretty a) => [([a], a2)] -> Doc
ppfds FunDeps
fds Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"where") Int
4
([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat (((Ident, Ty) -> Doc) -> [(Ident, Ty)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Ty) -> Doc
forall a2 a1. (Pretty a2, Pretty a1) => (a1, a2) -> Doc
ppSig [(Ident, Ty)]
sigs))
Instance [Ty]
ctx Ty
inst [(Lhs, Exp)]
eqns ->
Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (String
"instance"String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep [[Ty] -> Doc
forall a. Pretty a => [a] -> Doc
ppctx [Ty]
ctx,Ty -> Doc
forall a. Pretty a => a -> Doc
pp Ty
inst]Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"where") Int
4
([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat (((Lhs, Exp) -> Doc) -> [(Lhs, Exp)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Lhs, Exp) -> Doc
forall a a2 a1.
(PPA a, Pretty a2, Pretty a1) =>
((a1, [a]), a2) -> Doc
ppEqn [(Lhs, Exp)]
eqns))
TypeSig Ident
f Ty
ty -> Doc -> Int -> Ty -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (Ident
fIdent -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"::") Int
4 Ty
ty
Eqn Lhs
lhs Exp
rhs -> (Lhs, Exp) -> Doc
forall a a2 a1.
(PPA a, Pretty a2, Pretty a1) =>
((a1, [a]), a2) -> Doc
ppEqn (Lhs
lhs,Exp
rhs)
where
ppctx :: [a2] -> Doc
ppctx [a2]
ctx = case [a2]
ctx of
[] -> Doc
empty
[a2
p] -> a2
p a2 -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"=>"
[a2]
ps -> Doc -> Doc
forall a. Pretty a => a -> Doc
parens ([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep (String -> [a2] -> [Doc]
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> [a2] -> [Doc]
punctuate String
"," [a2]
ps)) Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"=>"
ppfds :: [([a], a2)] -> Doc
ppfds [] = Doc
empty
ppfds [([a], a2)]
fds = String
"|"String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep (String -> [Doc] -> [Doc]
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> [a2] -> [Doc]
punctuate String
"," [[a] -> Doc
forall a. Pretty a => [a] -> Doc
hsep [a]
asDoc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"->"Doc -> a2 -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>a2
bs|([a]
as,a2
bs)<-[([a], a2)]
fds])
ppEqn :: ((a1, [a]), a2) -> Doc
ppEqn ((a1
f,[a]
ps),a2
e) = Doc -> Int -> a2 -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (a1
fa1 -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. PPA a => a -> Doc
ppA [a]
ps)Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"=") Int
4 a2
e
ppSig :: (a1, a2) -> Doc
ppSig (a1
f,a2
ty) = a1
fa1 -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"::"Doc -> a2 -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>a2
ty
instance PPA a => Pretty (ConAp a) where
pp :: ConAp a -> Doc
pp (ConAp Ident
c [a]
as) = Ident
cIdent -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. PPA a => a -> Doc
ppA [a]
as)
instance Pretty Ty where
pp :: Ty -> Doc
pp = Ty -> Doc
ppT
where
ppT :: Ty -> Doc
ppT Ty
t = case Ty -> [Ty]
flatFun Ty
t of Ty
t:[Ty]
ts -> [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep (Ty -> Doc
ppB Ty
tDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[String
"->"String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>Ty -> Doc
ppB Ty
t|Ty
t<-[Ty]
ts])
ppB :: Ty -> Doc
ppB Ty
t = case Ty -> [Ty]
flatTAp Ty
t of Ty
t:[Ty]
ts -> Ty -> Doc
forall a. PPA a => a -> Doc
ppA Ty
tDoc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep ((Ty -> Doc) -> [Ty] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Ty -> Doc
forall a. PPA a => a -> Doc
ppA [Ty]
ts)
flatFun :: Ty -> [Ty]
flatFun (Fun Ty
t1 Ty
t2) = Ty
t1Ty -> [Ty] -> [Ty]
forall a. a -> [a] -> [a]
:Ty -> [Ty]
flatFun Ty
t2
flatFun Ty
t = [Ty
t]
flatTAp :: Ty -> [Ty]
flatTAp (TAp Ty
t1 Ty
t2) = Ty -> [Ty]
flatTAp Ty
t1[Ty] -> [Ty] -> [Ty]
forall a. [a] -> [a] -> [a]
++[Ty
t2]
flatTAp Ty
t = [Ty
t]
instance PPA Ty where
ppA :: Ty -> Doc
ppA Ty
t =
case Ty
t of
TId Ident
c -> Ident -> Doc
forall a. Pretty a => a -> Doc
pp Ident
c
ListT Ty
t -> Ty -> Doc
forall a. Pretty a => a -> Doc
brackets Ty
t
Ty
_ -> Ty -> Doc
forall a. Pretty a => a -> Doc
parens Ty
t
instance Pretty Exp where
pp :: Exp -> Doc
pp = Exp -> Doc
ppT
where
ppT :: Exp -> Doc
ppT Exp
e =
case Exp
e of
Op Exp
e1 String
op Exp
e2 -> Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (Exp -> Doc
ppB Exp
e1Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
op) Int
2 (Exp -> Doc
ppB Exp
e2)
Lets [(Ident, Exp)]
bs Exp
e -> [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep [String
"let"String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat [Doc -> Int -> Exp -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (Ident
xIdent -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"=") Int
2 Exp
xe|(Ident
x,Exp
xe)<-[(Ident, Exp)]
bs],
String
"in" String -> Exp -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>Exp
e]
LambdaCase [(Pat, Exp)]
alts ->
String -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang String
"\\case" Int
2 ([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat [Doc -> Int -> Exp -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (Pat
pPat -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>String
"->") Int
2 Exp
e|(Pat
p,Exp
e)<-[(Pat, Exp)]
alts])
Exp
_ -> Exp -> Doc
ppB Exp
e
ppB :: Exp -> Doc
ppB Exp
e = case Exp -> [Exp]
flatAp Exp
e of Exp
f:[Exp]
as -> Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (Exp -> Doc
forall a. PPA a => a -> Doc
ppA Exp
f) Int
2 ([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep ((Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Doc
forall a. PPA a => a -> Doc
ppA [Exp]
as))
flatAp :: Exp -> [Exp]
flatAp (Ap Exp
t1 Exp
t2) = Exp -> [Exp]
flatAp Exp
t1[Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++[Exp
t2]
flatAp Exp
t = [Exp
t]
instance PPA Exp where
ppA :: Exp -> Doc
ppA Exp
e =
case Exp
e of
Var Ident
x -> Ident -> Doc
forall a. Pretty a => a -> Doc
pp Ident
x
Const String
n -> String -> Doc
forall a. Pretty a => a -> Doc
pp String
n
Pair Exp
e1 Exp
e2 -> Doc -> Doc
forall a. Pretty a => a -> Doc
parens (Exp
e1Exp -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<>String
","Doc -> Exp -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<>Exp
e2)
List [Exp]
es -> Doc -> Doc
forall a. Pretty a => a -> Doc
brackets ([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep (String -> [Exp] -> [Doc]
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> [a2] -> [Doc]
punctuate String
"," [Exp]
es))
Exp
_ -> Exp -> Doc
forall a. Pretty a => a -> Doc
parens Exp
e
instance Pretty Pat where
pp :: Pat -> Doc
pp Pat
p =
case Pat
p of
ConP Ident
c [Pat]
ps -> Ident
cIdent -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Doc
forall a. PPA a => a -> Doc
ppA [Pat]
ps)
Pat
_ -> Pat -> Doc
forall a. PPA a => a -> Doc
ppA Pat
p
instance PPA Pat where
ppA :: Pat -> Doc
ppA Pat
p =
case Pat
p of
Pat
WildP -> String -> Doc
forall a. Pretty a => a -> Doc
pp String
"_"
VarP Ident
x -> Ident -> Doc
forall a. Pretty a => a -> Doc
pp Ident
x
Lit String
s -> String -> Doc
forall a. Pretty a => a -> Doc
pp String
s
ConP Ident
c [] -> Ident -> Doc
forall a. Pretty a => a -> Doc
pp Ident
c
AsP Ident
x Pat
p -> Ident
xIdent -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<>String
"@"Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<>Pat -> Doc
forall a. PPA a => a -> Doc
ppA Pat
p
Pat
_ -> Pat -> Doc
forall a. Pretty a => a -> Doc
parens Pat
p