TH.hs

{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell    #-}

module Dhall.Test.TH where

import Control.Exception      (throwIO)
import Data.Either.Validation (Validation (..))
import Data.Time              (TimeOfDay (..), TimeZone (..), fromGregorian)
import Dhall.TH               (HaskellType (..))
import Test.Tasty             (TestTree)

import qualified Data.Text
import qualified Dhall
import qualified Dhall.TH
import qualified Test.Tasty       as Tasty
import qualified Test.Tasty.HUnit as Tasty.HUnit

Dhall.TH.makeHaskellTypeFromUnion "T" "./tests/th/example.dhall"

deriving instance Eq   T
deriving instance Show T

Dhall.TH.makeHaskellTypes
    [ MultipleConstructors "Department" "./tests/th/Department.dhall"
    , SingleConstructor "Employee" "MakeEmployee" "./tests/th/Employee.dhall"
    , SingleConstructor "TimeExample" "TimeExample" "./tests/th/Time.dhall"
    ]

deriving instance Eq   Department
deriving instance Show Department

deriving instance Eq   Employee
deriving instance Show Employee

deriving instance Eq   TimeExample
deriving instance Show TimeExample

Dhall.TH.makeHaskellTypes
  [ SingleConstructor "Bar" "MakeBar" "(./tests/th/issue2066.dhall).Bar"
  , SingleConstructor "Foo" "MakeFoo" "(./tests/th/issue2066.dhall).Foo"
  , MultipleConstructors "Qux" "(./tests/th/issue2066.dhall).Qux"
  ]

deriving instance Eq   Bar
deriving instance Show Bar

deriving instance Eq   Foo
deriving instance Show Foo

deriving instance Eq   Qux
deriving instance Show Qux

tests :: TestTree
tests = Tasty.testGroup "Template Haskell" [ makeHaskellTypeFromUnion ]

makeHaskellTypeFromUnion :: TestTree
makeHaskellTypeFromUnion = Tasty.HUnit.testCase "makeHaskellTypeFromUnion" $ do
    t0 <- Dhall.input Dhall.auto "let T = ./tests/th/example.dhall in T.A { x = True, y = [ \"ABC\" ] }"

    Tasty.HUnit.assertEqual "" t0 A{ x = True, y = [ "ABC" ] }

    t1 <- Dhall.input Dhall.auto "let T = ./tests/th/example.dhall in T.B (Some [ 1 ])"

    Tasty.HUnit.assertEqual "" t1 (B (Just [ 1 ]))

    t2 <- Dhall.input Dhall.auto "let T = ./tests/th/example.dhall in T.C"

    Tasty.HUnit.assertEqual "" t2 C

    employee <- Dhall.input Dhall.auto "let Department = ./tests/th/Department.dhall in { name = \"John\", department = Department.Marketing }"

    Tasty.HUnit.assertEqual "" employee MakeEmployee{ name = "John", department = Marketing }

    qux <- Dhall.input Dhall.auto "let T = ./tests/th/issue2066.dhall in T.Qux.Foo { foo = +2, bar = { baz = +3 } }"

    Tasty.HUnit.assertEqual "" qux (Foo MakeFoo{ foo = 2, bar = MakeBar{ baz = 3 } })

    timex <- Dhall.input Dhall.auto "let T = ./tests/th/Time.dhall in { txTime = 21:12:00, txDate = 1976-04-01, txTimeZone = +05:00 } : T"

    Tasty.HUnit.assertEqual "" timex TimeExample { txTime = tod, txDate = day, txTimeZone = tz}

    where
      tod = TimeOfDay { todHour = 21, todMin = 12, todSec = 0 }
      day = fromGregorian 1976 4 1
      tz = TimeZone { timeZoneMinutes = 300, timeZoneSummerOnly = False, timeZoneName = "" }
  

Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions
    { Dhall.TH.constructorModifier = ("My" <>)
    , Dhall.TH.fieldModifier = ("my" <>) . Data.Text.toTitle
    })
    [ MultipleConstructors "MyT" "./tests/th/example.dhall"
    , MultipleConstructors "MyDepartment" "./tests/th/Department.dhall"
    , SingleConstructor "MyEmployee" "Employee" "./tests/th/Employee.dhall"
    ]

  
deriving instance Eq   MyT
deriving instance Eq   MyDepartment
deriving instance Eq   MyEmployee
deriving instance Show MyT
deriving instance Show MyDepartment
deriving instance Show MyEmployee

  
Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions
    { Dhall.TH.constructorModifier = ("My" <>)
    , Dhall.TH.fieldModifier = ("my" <>) . Data.Text.toTitle
    , Dhall.TH.generateFromDhallInstance = False
    , Dhall.TH.generateToDhallInstance = False
    })
    [ SingleConstructor "MyHKSingle" "HKSingle" "./tests/th/HigherKindSingle.dhall"
    , MultipleConstructors "MyHKUnion" "./tests/th/HigherKindUnion.dhall"
    ]

type MyHKSingle_ = MyHKSingle Maybe Int
type MyHKUnion_ = MyHKUnion Bool Int

deriving instance Eq MyHKSingle_
deriving instance Show MyHKSingle_
deriving instance Dhall.Generic MyHKSingle_
instance Dhall.FromDhall MyHKSingle_
instance Dhall.ToDhall MyHKSingle_

deriving instance Eq MyHKUnion_
deriving instance Show MyHKUnion_
deriving instance Dhall.Generic MyHKUnion_
instance Dhall.FromDhall MyHKUnion_
instance Dhall.ToDhall MyHKUnion_

testMakeHaskellTypesWith :: TestTree
testMakeHaskellTypesWith = Tasty.HUnit.testCase "makeHaskellTypesWith" $ do
    let text0 = "let T = ./tests/th/example.dhall in T.A { x = True, y = [] : List Text }"
        ref0 = MyA{ myX = True, myY = [] }
    myTest text0 ref0

    let text1 = "let T = ./tests/th/example.dhall in T.B (None (List Natural))"
        ref1 = MyB Nothing
    myTest text1 ref1

    let text2 = "let T = ./tests/th/example.dhall in T.C"
        ref2 = MyC
    myTest text2 ref2

    let textDepartment = "let T = ./tests/th/Department.dhall in T.Sales"
        refDepartment = MySales
    myTest textDepartment refDepartment

    let textEmployee = "let T = ./tests/th/Department.dhall in T.Sales"
        refEmployee = MyEmployee{ myName = "", myDepartment = MySales }
    myTest textEmployee refEmployee

    let textHKSingle = "let T = (./tests/th/HigherKindSingle.dhall) Optional Int in T { foo = +1, bar = Some +2, bam = \"\" }"
        refHKSingle = MyHKSingle { myFoo = 1, myBar = Just 2, myBam = "" } :: MyHKSingle_
    myTest textHKSingle refHKSingle

    let textHKUnion0 = "let T = (./tests/th/HigherKindUnion.dhall) Bool Int in T.Foo True"
        refHKUnion0 = MyFoo True :: MyHKUnion_
    myTest textHKUnion0 refHKUnion0

    let textHKUnion1 = "let T = (./tests/th/HigherKindUnion.dhall) Bool Int in T.Bar +1"
        refHKUnion1 = MyBar 1 :: MyHKUnion_
    myTest textHKUnion1 refHKUnion1

    where
        myTest text ref = do
            expr <- Dhall.inputExpr text
            t <- case Dhall.extract Dhall.auto expr of
                Failure e -> throwIO e
                Success t -> return t

            Tasty.HUnit.assertEqual "" t ref
            Tasty.HUnit.assertEqual "" expr $ Dhall.embed Dhall.inject ref

Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions
    { Dhall.TH.constructorModifier = ("NoFromDhall" <>)
    , Dhall.TH.fieldModifier = ("noFromDhall" <>) . Data.Text.toTitle
    , Dhall.TH.generateFromDhallInstance = False
    })
    [ MultipleConstructors "NoFromDhallT" "./tests/th/example.dhall"
    ]

instance Dhall.FromDhall NoFromDhallT

Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions
    { Dhall.TH.constructorModifier = ("NoToDhall" <>)
    , Dhall.TH.fieldModifier = ("noToDhall" <>) . Data.Text.toTitle
    , Dhall.TH.generateToDhallInstance = False
    })
    [ MultipleConstructors "NoToDhallT" "./tests/th/example.dhall"
    ]

instance Dhall.ToDhall NoToDhallT

Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions
    { Dhall.TH.constructorModifier = ("NoInstances" <>)
    , Dhall.TH.fieldModifier = ("noInstances" <>) . Data.Text.toTitle
    , Dhall.TH.generateFromDhallInstance = False
    , Dhall.TH.generateToDhallInstance = False
    })
    [ MultipleConstructors "NoInstancesT" "./tests/th/example.dhall"
    ]

deriving instance Dhall.Generic NoInstancesT
instance Dhall.FromDhall NoInstancesT
instance Dhall.ToDhall NoInstancesT

Dhall.TH.makeHaskellTypesWith (Dhall.TH.defaultGenerateOptions
    { Dhall.TH.constructorModifier = ("Strict" <>)
    , Dhall.TH.fieldModifier = ("strict" <>) . Data.Text.toTitle
    , Dhall.TH.makeStrict = True
    })
    [ MultipleConstructors "StrictFields" "./tests/th/example.dhall"
    ]