ghc-source-gen/tests/pprint_examples.hs

-- Copyright 2019 Google LLC
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd

-- | Simple example using this package
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Main (main) where

import GHC.Paths (libdir)
import GHC (runGhc)
import GHC.Utils.Outputable (Outputable)

import GHC.SourceGen

main :: IO ()
main = mapM_ run [test1, test2, test3, test4, test5]
  where
    run act = putStrLn "========" >> act

pprint :: Outputable a => a -> IO ()
pprint x = runGhc (Just libdir) $ putPpr x

test1 :: IO ()
test1 = pprint $ tuple
    [ var "Foo.abc"
    , overLabel "def"
    , char 'g'
    , let' [ typeSig "result" $ var "A" @@ var "B"
           , funBind "result"
                $ match [bvar "x", wildP]
                    $ var "foo" @@ char 'c'
           ]
        (var "result")
    ]

test2 :: IO ()
test2 = pprint $ module' (Just "Foo") (Just [var "efg"]) []
    [ typeSigs ["efg", "h"] $ tuple [var "A", var "B"]
    , funBind "efg"
        $ matchGRHSs []
        $ rhs (char 'a')
            `where'` [ typeSig "q" $ var "Q"
                     , funBind "q" $ matchGRHSs []
                        $ guardedRhs [var "True" `guard` char 'q']
                     ]
    , funBind "f"
        $ matchGRHSs [bvar "x", bvar "y"]
        $ rhs
            (case' (var "y")
                        [match [wildP] $ var "x"])
            `where'` [funBind "q" $ match [] $ char 't']
    ]

test3 :: IO ()
test3 = pprint $ module' Nothing Nothing []
    [ funBind "lambdas" $ match [] $ lambda [bvar "y"]
                    $ lambdaCase [match [bvar "z"] (char 'a')]
    , funBinds "ifs"
        [ match [bvar "x"] $ if' (var "b") (var "t") (var "f")
        , match [bvar "y"] $ multiIf [guard (var "False") $ char 'f'
                                       , guard (var "True") $ char 't'
                                       ]
        , match [bvar "z"] $ multiIf
            [ guard (var "f" @@ var "x") $ string "f"
            , guard (var "g" @@ var "x") $ string "g"
            , guard (var "otherwise") $ string "h"
            ]
        ]
    , funBind "do'"
        $ match [] (do' [ bvar "x" <-- var "act"
                        , stmt $ var "return" @@ var "x"
                        ])
    , typeSig "types"
        $ forall' [bvar "x", bvar "y"]
        $ [var "Show" @@ var "x"] ==> var "y"
    , typeSig "types'"
        $ [var "Show" @@ var "x"] ==>
            (forall' [bvar "x", bvar "y"]
                $ var "y")
    , funBind "swap"
        $ match [tuple [bvar "x", bvar "y"]]
            $ tuple [var "y", var "x"]
    , funBind "char" $ match [char 'a'] (char 'b')
    , funBind "string" $ match [string "abc"] (string "def")
    , funBind "as"
        $ match [asP "x" (tuple [bvar "y", bvar "z"])]
            (var "x")
    , funBind "con"
        $ match [conP "A" [bvar "b", conP "C" [bvar "d"]]]
            $ tuple [var "b", var "d"]
    , funBind "ops"
        $ match [bvar "x", bvar "y"]
            $ op (var "x") "+" (var "y")
    , funBinds "ops'"
        [ match [] (op (int 1) "*"
                        (op (int 2) "+" (int 3)))
        , match [] (op (var "A" @@ var "x") "*"
                        (op (var "B" @@ var "y") "+"
                                 (var "C" @@ var "z")))
        , match [] (op (var "A" @@ var "x") "mult"
                        (op (var "B" @@ var "y") "+"
                                 (var "C" @@ var "z")))
        ]
    , funBinds "cons'"
        [ match [] (var "X" @@ int 1 @@
                        (var "Y" @@ int 2 @@ int 3)
                        @@ var "Z")
        , match [] (var "f" @@ par (var "g" @@ var "x"))
        ]
    , typeSig "f" $ var "X" @@ var "a" @@
                        (var "Y" @@ var "b" @@ var "c")
                        @@ var "Z"
    , typeSig "g" $ op (var "A" @@ var "x") "*"
                        (op (var "B" @@ var "y") "+"
                                 (var "C" @@ var "z"))
    , class' [var "A" @@ var "a"] "B" [bvar "b", bvar "b'"]
        [ typeSig "f" $ var "b" --> var "b'"
        , funBind "f" $ match [] $ var "id"
        ]
    , class' [] "F" [bvar "a", bvar "b", bvar "c"]
        [ funDep ["a", "b"] ["c"]
        , funDep ["a"] ["b", "c"]
        ]
    , class' [] "Ident" [bvar "a", bvar "b"]
        [ funDep ["a"] ["b"]
        , funDep ["b"] ["a"]
        , typeSig "ident" $ var "a" --> var "b"
        ]
    , type' "A" [bvar "b", bvar "c"] $ var "D"
    , data' "A" [bvar "b", bvar "c"]
        [ prefixCon "A" [field (var "b"), field (var "c")]
        , prefixCon "D" []
        ]
        [deriving' [var "X", var "Y"]]
    , newtype' "A" [bvar "b", bvar "c"] (prefixCon "A" [field (var "b")])
        [deriving' [var "X", var "Y"]]
    , instance' (var "A" @@ var "b" @@ var "c")
        [ typeSig "f" $ var "b" --> var "c"
        , funBind "f" $ match [] $ var "undefined"
        ]
    , let a = var "a"
      in class'
           [var "Real" @@ a, var "Enum" @@ a]
           "Integral"
           [bvar "a"]
           [ typeSig "divMod" $ a --> a --> tuple [a, a]
           , typeSig "div" $ a --> a --> a
           , funBind "div"
               $ match [bvar "x", bvar "y"]
                  $ var "fst" @@ (var "divMod" @@ var "x" @@ var "y")
           ]
    , instance' (var "Show" @@ var "Bool")
        [ typeSig "show" $ var "Bool" --> var "String"
        , funBinds "show"
            [ match [conP "True" []] $ string "True"
            , match [conP "False" []] $ string "False"
            ]
        ]
    , data' "X" [bvar "b"]
        [ prefixCon "X"
            [ field $ var "A" @@ var "b"
            , strict $ field $ var "A" @@ var "b"
            , lazy $ field $ var "A" @@ var "b"
            ]
        , prefixCon ":+"
            [ field $ var "A" @@ var "b"
            , strict $ field $ var "A" @@ var "b"
            , lazy $ field $ var "A" @@ var "b"
            ]
        , infixCon
            (strict $ field $ var "A" @@ var "b")
            "Y"
            (lazy $ field $ var "A" @@ var "b")
        , infixCon
            (strict $ field $ var "A" @@ var "b")
            ":*"
            (lazy $ field $ var "A" @@ var "b")
        , infixCon
            (field $ var "A" @@ var "b")
            ":*"
            (field $ var "A" @@ var "b")
        , recordCon "Z"
            [ ("x", field $ var "Int")
            , ("y", field $ var "A" @@ var "b")
            , ("y", strict $ field $ var "A" @@ var "b")
            , ("y", lazy $ field $ var "A" @@ var "b")
            ]
        ]
        []
    , funBind "strictness"
        $ match
            [strictP (conP "A" [bvar "b"]),
             lazyP (conP "A" [bvar "b"])
            ] (char 'x')
    , typeSig "unit" $ unit --> unit
    , funBind "unit" $ match [unit] unit
    ]

test4 :: IO ()
test4 = pprint constModule

test5 :: IO ()
test5 = pprint $ module' (Just "M") (Just exports) imports []
  where
    exports = [ var "a"
              , var "A"
              , thingAll "B"
              , thingWith "C" ["d", "E"]
              ]
    imports = [ qualified' $ import' "A"
              , import' "B" `as'` "C"
              , import' "D" `exposing` [var "d"]
              , import' "E" `hiding` [var "e"]
              ]

constModule :: HsModule'
constModule = module' (Just "Const") (Just [var "const"]) []
    [ typeSig "const" $ a --> b --> a
    , funBind "const" $ match [wildP, x] x
    ]
  where
    a = bvar "a"
    b = bvar "b"
    x = bvar "x"