{-# LANGUAGE ImportQualifiedPost #-}

module Constrained.Syntax where

import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH

mkNamed :: String -> TH.Q TH.Pat
mkNamed :: String -> Q Pat
mkNamed String
x =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Exp -> Pat -> Pat
TH.ViewP (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"name") (Lit -> Exp
TH.LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
TH.StringL String
x)) (Name -> Pat
TH.VarP forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
x)

mkNamedExpr :: String -> TH.Q TH.Exp
mkNamedExpr :: String -> Q Exp
mkNamedExpr String
x =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"name") (Lit -> Exp
TH.LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
TH.StringL String
x)) (Name -> Exp
TH.VarE forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
x)

var :: TH.QuasiQuoter
var :: QuasiQuoter
var =
  TH.QuasiQuoter
    { -- Parses variables e.g. `constrained $ \ [var| x |] [var| y |] -> ...` from the strings " x " and " y "
      -- and replaces them with `name "x" -> x` and `name "y" -> y`
      quotePat :: String -> Q Pat
TH.quotePat = String -> Q Pat
mkNamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
varName
    , -- Parses variables in expressions like `assert $ [var| x |] + 3 <. 10` and replaces them with `name "x" x`
      quoteExp :: String -> Q Exp
TH.quoteExp = String -> Q Exp
mkNamedExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
varName
    , quoteDec :: String -> Q [Dec]
TH.quoteDec = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"var should only be used at binding sites and in expressions"
    , quoteType :: String -> Q Type
TH.quoteType = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"var should only be used at binding sites and in expressions"
    }
  where
    varName :: String -> String
varName String
s = case String -> [String]
words String
s of
      [String
w] -> String
w
      [String]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected a single var name"