Haskell.hs 3.81 KB
Newer Older
1
2
{-# OPTIONS_GHC -Wall #-}

3
module Printer.Haskell where
4
5

import Data.Text.Prettyprint.Doc
6
import Data.Maybe
7
import Program
8
import Utility
9
import GeneralTerms
10

marton bognar's avatar
marton bognar committed
11
instance Pretty Constructor where
12
  pretty (Constr n ts) = hsep (pretty (upperFirst n) : map pretty ts)
marton bognar's avatar
marton bognar committed
13
14

instance Pretty Parameter where
15
16
  pretty (VarParam n) = pretty (lowerFirst n)
  pretty (ConstrParam n ps) = parens (hsep (pretty (upperFirst n) : map pretty ps))
17
18
  pretty (StringParam s) = pretty "\"" <> pretty s <> pretty "\""
  pretty (IntParam i) = pretty i
marton bognar's avatar
marton bognar committed
19
20

instance Pretty Expression where
21
22
23
  pretty (FnCall n ps) = parens $ hsep (pretty (lowerFirst n) : map pretty ps)
  pretty (ConstrInst n ps) = parens $ hsep (pretty (upperFirst n) : map pretty ps)
  pretty (VarExpr x) = pretty (lowerFirst x)
24
  pretty (Minus a b) = parens (pretty a <+> pretty "-" <+> pretty b)
25
26
27
  pretty (IntExpr i) = pretty i
  pretty (StringExpr s) = pretty "\"" <> pretty s <> pretty "\""
  pretty (IfExpr c t f) = pretty "if" <+> pretty c <+> pretty "then" <+> pretty t <+> pretty "else" <+> pretty f
28
29
  pretty (GTEExpr a b) = parens (pretty a <+> pretty ">=" <+> pretty b)
  pretty (EQExpr a b) = parens (pretty a <+> pretty "==" <+> pretty b)
30
  pretty (ListExpr l) = pretty "[" <> hcat (punctuate comma (map pretty l)) <> pretty "]"
31
  pretty (LambdaExpr ps ex) = parens (pretty "\\" <> hsep (map pretty ps) <+> pretty "->" <+> pretty ex)
marton bognar's avatar
marton bognar committed
32
33
34
35

instance Pretty Function where
  pretty (Fn n lns) = intoLines (map oneLine lns) where
    oneLine :: ([Parameter], Expression) -> Doc a
36
    oneLine (ps, ex) = hsep $ (pretty (lowerFirst n) : map pretty ps) ++ [pretty "=", pretty ex]
marton bognar's avatar
marton bognar committed
37
38
39
40
41
42
43

nl :: Doc a
nl = pretty "\n"

intoLines :: [Doc a] -> Doc a
intoLines = hcat . punctuate nl

44
45
printProgram :: String -> Program -> Doc String
printProgram name program =
marton bognar's avatar
marton bognar committed
46
  intoLines [
47
    printModuleDecl name,
48
    printImports (("Data.List", []) : imports program),
marton bognar's avatar
marton bognar committed
49
    printTypeDecls (types program),
50
    nl,
51
    freshVarFunctions (types program),
marton bognar's avatar
marton bognar committed
52
    printFunctions (functions program),
53
    printInstances (instances program),
marton bognar's avatar
marton bognar committed
54
    printCode (code program)
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
  ]

printModuleDecl :: String -> Doc String
printModuleDecl name = hsep [pretty "module", pretty name, pretty "where"]

printImports :: [(String, [String])] -> Doc String
printImports imp =
  foldl
    (<>)
    (pretty "")
    (map (\x -> genImports x <+> pretty "\n") imp)
  where
    genImports :: (String, [String]) -> Doc String
    genImports (str, []) = pretty "import" <+> pretty str
    genImports (str, rest) =
      pretty "import" <+> pretty str <+> parens (hsep (punctuate comma [pretty x | x <- rest]))

printTypeDecls :: [(Type, [Constructor])] -> Doc String
printTypeDecls decls =
74
  intoLines $ punctuate nl $ map printOneType decls where
75
76
77
    printOneType :: (Type, [Constructor]) -> Doc String
    printOneType (t, cs) = hsep [
        pretty "data",
78
        pretty (upperFirst t),
79
        pretty "=",
80
        hsep $ punctuate (pretty " |") (map pretty cs),
81
82
        pretty "deriving(Show, Eq)"
      ]
marton bognar's avatar
marton bognar committed
83
84

printFunctions :: [Function] -> Doc String
85
printFunctions fns = intoLines $ punctuate nl (map pretty fns)
marton bognar's avatar
marton bognar committed
86

87
88
89
printInstances :: [(Type, Type, [Function])] -> Doc String
printInstances ids = intoLines $ map (
    \(cls, typ, fns) -> intoLines [
90
      hsep [pretty "instance", pretty (upperFirst cls), pretty (upperFirst typ), pretty "where"],
91
      printFunctions (map (\(Fn n lns) -> Fn ("  " ++ n) lns) fns)
92
93
94
    ]
  ) ids

marton bognar's avatar
marton bognar committed
95
96
printCode :: [String] -> Doc String
printCode lns = intoLines $ map pretty lns
97
98
99
100
101
102
103
104

freshVarFunctions :: [(Type, [Constructor])] -> Doc String
freshVarFunctions types
  = let ctors = fromJust (lookup "Variable" types)
        names = map (\(Constr name _) -> tail name) ctors
    in intoLines [
      pretty ("fresh" ++ name ++ " x b = if not (x `elem` b) then x else head [S" ++ name ++ " ('v' : show n) | n <- [0..], not (S" ++ name ++ " ('v' : show n) `elem` b)]")
    | name <- names]