-- | 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 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,[])

-- | 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 :: 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

-- | 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 :: 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 -- right associative
      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] -- left associative
      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] -- left associative
      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