{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE OverloadedStrings  #-}

module Language.Haskell.Liquid.UX.QuasiQuoter 
-- (
--     -- * LiquidHaskell Specification QuasiQuoter
--     lq

--     -- * QuasiQuoter Annotations
--   , LiquidQuote(..)
--   ) 
  where

import SrcLoc (SrcSpan)

import Data.Data
import Data.List

import qualified Data.Text as T

import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote

import Text.Parsec.Pos

import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan)
import qualified Language.Fixpoint.Types as F

import Language.Haskell.Liquid.GHC.Misc (fSrcSpan)
import Language.Haskell.Liquid.Parse
import Language.Haskell.Liquid.Types
import Language.Haskell.Liquid.UX.Tidy

--------------------------------------------------------------------------------
-- LiquidHaskell Specification QuasiQuoter -------------------------------------
--------------------------------------------------------------------------------

lq :: QuasiQuoter
lq :: QuasiQuoter
lq = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
forall a. a
bad
  , quotePat :: String -> Q Pat
quotePat  = String -> Q Pat
forall a. a
bad
  , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. a
bad
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
lqDec
  }
  where
    -- FIME(adinapoli) Should we preserve 'fail' here?
    bad :: a
bad = String -> a
forall a. HasCallStack => String -> a
error String
"`lq` quasiquoter can only be used as a top-level declaration"

lqDec :: String -> Q [Dec]
lqDec :: String -> Q [Dec]
lqDec String
src = do
  SourcePos
pos <- Loc -> SourcePos
locSourcePos (Loc -> SourcePos) -> Q Loc -> Q SourcePos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
  case SourcePos -> String -> Either Error BPspec
singleSpecP SourcePos
pos String
src of
    Left Error
err -> UserError -> Q [Dec]
forall a. UserError -> Q a
throwErrorInQ (UserError -> Q [Dec]) -> UserError -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Error -> UserError
errorToUserError Error
err
    Right BPspec
spec -> do
      Dec
prg <- AnnTarget -> Q Exp -> DecQ
pragAnnD AnnTarget
ModuleAnnotation (Q Exp -> DecQ) -> Q Exp -> DecQ
forall a b. (a -> b) -> a -> b
$
               Name -> Q Exp
conE 'LiquidQuote Q Exp -> Q Exp -> Q Exp
`appE` BPspec -> Q Exp
forall a. Data a => a -> Q Exp
dataToExpQ' BPspec
spec
      case BPspec -> Either UserError [Dec]
mkSpecDecs BPspec
spec of
        Left UserError
err ->
          UserError -> Q [Dec]
forall a. UserError -> Q a
throwErrorInQ UserError
err
        Right [Dec]
decs ->
          [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
prg Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
decs

throwErrorInQ :: UserError -> Q a
throwErrorInQ :: UserError -> Q a
throwErrorInQ UserError
err =
  String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a)
-> ([CtxError Doc] -> String) -> [CtxError Doc] -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CtxError Doc] -> String
forall a. PPrint a => a -> String
showpp ([CtxError Doc] -> Q a) -> Q [CtxError Doc] -> Q a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [CtxError Doc] -> Q [CtxError Doc]
forall a. IO a -> Q a
runIO ([UserError] -> IO [CtxError Doc]
errorsWithContext [UserError
err])

--------------------------------------------------------------------------------
-- Liquid Haskell to Template Haskell ------------------------------------------
--------------------------------------------------------------------------------

-- Spec to Dec -----------------------------------------------------------------

mkSpecDecs :: BPspec -> Either UserError [Dec]
mkSpecDecs :: BPspec -> Either UserError [Dec]
mkSpecDecs (Asrt (LocSymbol
name, LocBareType
ty)) =
  Dec -> [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> [Dec]) -> (Type -> Dec) -> Type -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> Dec
SigD (LocSymbol -> Name
forall s. Symbolic s => s -> Name
symbolName LocSymbol
name)
    (Type -> [Dec]) -> Either UserError Type -> Either UserError [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocSymbol -> BareType -> Either UserError Type
simplifyBareType LocSymbol
name (BareType -> BareType
forall r tv c. (Monoid r, Eq tv) => RType c tv r -> RType c tv r
quantifyFreeRTy (BareType -> BareType) -> BareType -> BareType
forall a b. (a -> b) -> a -> b
$ LocBareType -> BareType
forall a. Located a -> a
val LocBareType
ty)
mkSpecDecs (LAsrt (LocSymbol
name, LocBareType
ty)) =
  Dec -> [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> [Dec]) -> (Type -> Dec) -> Type -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> Dec
SigD (LocSymbol -> Name
forall s. Symbolic s => s -> Name
symbolName LocSymbol
name)
    (Type -> [Dec]) -> Either UserError Type -> Either UserError [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocSymbol -> BareType -> Either UserError Type
simplifyBareType LocSymbol
name (BareType -> BareType
forall r tv c. (Monoid r, Eq tv) => RType c tv r -> RType c tv r
quantifyFreeRTy (BareType -> BareType) -> BareType -> BareType
forall a b. (a -> b) -> a -> b
$ LocBareType -> BareType
forall a. Located a -> a
val LocBareType
ty)
mkSpecDecs (Asrts ([LocSymbol]
names, (LocBareType
ty, Maybe [Located Expr]
_))) =
  (\Type
t -> (Name -> Type -> Dec
`SigD` Type
t) (Name -> Dec) -> (LocSymbol -> Name) -> LocSymbol -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocSymbol -> Name
forall s. Symbolic s => s -> Name
symbolName (LocSymbol -> Dec) -> [LocSymbol] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocSymbol]
names)
    (Type -> [Dec]) -> Either UserError Type -> Either UserError [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocSymbol -> BareType -> Either UserError Type
simplifyBareType ([LocSymbol] -> LocSymbol
forall a. [a] -> a
head [LocSymbol]
names) (BareType -> BareType
forall r tv c. (Monoid r, Eq tv) => RType c tv r -> RType c tv r
quantifyFreeRTy (BareType -> BareType) -> BareType -> BareType
forall a b. (a -> b) -> a -> b
$ LocBareType -> BareType
forall a. Located a -> a
val LocBareType
ty)
mkSpecDecs (Alias Located (RTAlias Symbol BareType)
rta) =
  Dec -> [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> [Dec]) -> (Type -> Dec) -> Type -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> [TyVarBndr] -> Type -> Dec
TySynD Name
name [TyVarBndr]
tvs) (Type -> [Dec]) -> Either UserError Type -> Either UserError [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocSymbol -> BareType -> Either UserError Type
simplifyBareType LocSymbol
lsym (RTAlias Symbol BareType -> BareType
forall x a. RTAlias x a -> a
rtBody (Located (RTAlias Symbol BareType) -> RTAlias Symbol BareType
forall a. Located a -> a
val Located (RTAlias Symbol BareType)
rta))
  where
    lsym :: LocSymbol
lsym = Located (RTAlias Symbol BareType) -> Symbol -> LocSymbol
forall l b. Loc l => l -> b -> Located b
F.atLoc Located (RTAlias Symbol BareType)
rta Symbol
n 
    name :: Name
name = Symbol -> Name
forall s. Symbolic s => s -> Name
symbolName Symbol
n 
    n :: Symbol
n    = RTAlias Symbol BareType -> Symbol
forall x a. RTAlias x a -> Symbol
rtName (Located (RTAlias Symbol BareType) -> RTAlias Symbol BareType
forall a. Located a -> a
val Located (RTAlias Symbol BareType)
rta)
    tvs :: [TyVarBndr]
tvs  = Name -> TyVarBndr
PlainTV (Name -> TyVarBndr) -> (Symbol -> Name) -> Symbol -> TyVarBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Name
forall s. Symbolic s => s -> Name
symbolName (Symbol -> TyVarBndr) -> [Symbol] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RTAlias Symbol BareType -> [Symbol]
forall x a. RTAlias x a -> [x]
rtTArgs (Located (RTAlias Symbol BareType) -> RTAlias Symbol BareType
forall a. Located a -> a
val Located (RTAlias Symbol BareType)
rta)
mkSpecDecs BPspec
_ =
  [Dec] -> Either UserError [Dec]
forall a b. b -> Either a b
Right []

-- Symbol to TH Name -----------------------------------------------------------

symbolName :: Symbolic s => s -> Name
symbolName :: s -> Name
symbolName = String -> Name
mkName (String -> Name) -> (s -> String) -> s -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> String
symbolString (Symbol -> String) -> (s -> Symbol) -> s -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Symbol
forall a. Symbolic a => a -> Symbol
symbol

-- BareType to TH Type ---------------------------------------------------------

simplifyBareType :: LocSymbol -> BareType -> Either UserError Type
simplifyBareType :: LocSymbol -> BareType -> Either UserError Type
simplifyBareType LocSymbol
s BareType
t = case BareType -> Simpl Type
simplifyBareType' BareType
t of
  Simplified Type
t' ->
    Type -> Either UserError Type
forall a b. b -> Either a b
Right Type
t'
  FoundExprArg SrcSpan
l ->
    UserError -> Either UserError Type
forall a b. a -> Either a b
Left (UserError -> Either UserError Type)
-> UserError -> Either UserError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Doc -> Doc -> Doc -> Doc -> UserError
forall t. SrcSpan -> Maybe Doc -> Doc -> t -> Doc -> TError t
ErrTySpec SrcSpan
l Maybe Doc
forall a. Maybe a
Nothing (Symbol -> Doc
forall a. PPrint a => a -> Doc
pprint (Symbol -> Doc) -> Symbol -> Doc
forall a b. (a -> b) -> a -> b
$ LocSymbol -> Symbol
forall a. Located a -> a
val LocSymbol
s) (BareType -> Doc
forall a. PPrint a => a -> Doc
pprint BareType
t) (Doc -> UserError) -> Doc -> UserError
forall a b. (a -> b) -> a -> b
$ 
      Doc
"Found expression argument in bad location in type"
  Simpl Type
FoundHole ->
    UserError -> Either UserError Type
forall a b. a -> Either a b
Left (UserError -> Either UserError Type)
-> UserError -> Either UserError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Doc -> Doc -> Doc -> Doc -> UserError
forall t. SrcSpan -> Maybe Doc -> Doc -> t -> Doc -> TError t
ErrTySpec (LocSymbol -> SrcSpan
forall a. Loc a => a -> SrcSpan
fSrcSpan LocSymbol
s) Maybe Doc
forall a. Maybe a
Nothing (Symbol -> Doc
forall a. PPrint a => a -> Doc
pprint (Symbol -> Doc) -> Symbol -> Doc
forall a b. (a -> b) -> a -> b
$ LocSymbol -> Symbol
forall a. Located a -> a
val LocSymbol
s) (BareType -> Doc
forall a. PPrint a => a -> Doc
pprint BareType
t) (Doc -> UserError) -> Doc -> UserError
forall a b. (a -> b) -> a -> b
$ 
      Doc
"Can't write LiquidHaskell type with hole in a quasiquoter"

simplifyBareType' :: BareType -> Simpl Type
simplifyBareType' :: BareType -> Simpl Type
simplifyBareType' = ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' ([], [])

simplifyBareType'' :: ([BTyVar], [BareType]) -> BareType -> Simpl Type

simplifyBareType'' :: ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' ([], []) (RVar BTyVar
v RReft
_) =
  Type -> Simpl Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Simpl Type) -> Type -> Simpl Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ BTyVar -> Name
forall s. Symbolic s => s -> Name
symbolName BTyVar
v
simplifyBareType'' ([], []) (RAppTy BareType
t1 BareType
t2 RReft
_) =
  Type -> Type -> Type
AppT (Type -> Type -> Type) -> Simpl Type -> Simpl (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BareType -> Simpl Type
simplifyBareType' BareType
t1 Simpl (Type -> Type) -> Simpl Type -> Simpl Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BareType -> Simpl Type
simplifyBareType' BareType
t2
simplifyBareType'' ([], []) (RFun Symbol
_ BareType
i BareType
o RReft
_) =
  (\Type
x Type
y -> Type
ArrowT Type -> Type -> Type
`AppT` Type
x Type -> Type -> Type
`AppT` Type
y)
    (Type -> Type -> Type) -> Simpl Type -> Simpl (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BareType -> Simpl Type
simplifyBareType' BareType
i Simpl (Type -> Type) -> Simpl Type -> Simpl Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BareType -> Simpl Type
simplifyBareType' BareType
o
simplifyBareType'' ([], []) (RApp BTyCon
cc [BareType]
as [RTProp BTyCon BTyVar RReft]
_ RReft
_) =
  let c :: LocSymbol
c  = BTyCon -> LocSymbol
btc_tc BTyCon
cc
      c' :: Type
c' | LocSymbol -> Bool
forall c. TyConable c => c -> Bool
isFun   LocSymbol
c = Type
ArrowT
         | LocSymbol -> Bool
forall c. TyConable c => c -> Bool
isTuple LocSymbol
c = Int -> Type
TupleT ([BareType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BareType]
as)
         | LocSymbol -> Bool
forall c. TyConable c => c -> Bool
isList  LocSymbol
c = Type
ListT
         | Bool
otherwise = Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ LocSymbol -> Name
forall s. Symbolic s => s -> Name
symbolName LocSymbol
c
  in  (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT Type
c' ([Type] -> Type) -> Simpl [Type] -> Simpl Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Simpl Type] -> Simpl [Type]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Simpl Type] -> [Simpl Type]
forall a. [Simpl a] -> [Simpl a]
filterExprArgs ([Simpl Type] -> [Simpl Type]) -> [Simpl Type] -> [Simpl Type]
forall a b. (a -> b) -> a -> b
$ BareType -> Simpl Type
simplifyBareType' (BareType -> Simpl Type) -> [BareType] -> [Simpl Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BareType]
as)

simplifyBareType'' ([BTyVar], [BareType])
_ (RExprArg Located Expr
e) =
  SrcSpan -> Simpl Type
forall a. SrcSpan -> Simpl a
FoundExprArg (SrcSpan -> Simpl Type) -> SrcSpan -> Simpl Type
forall a b. (a -> b) -> a -> b
$ Located Expr -> SrcSpan
forall a. Loc a => a -> SrcSpan
fSrcSpan Located Expr
e
simplifyBareType'' ([BTyVar], [BareType])
_ (RHole RReft
_) =
  Simpl Type
forall a. Simpl a
FoundHole

simplifyBareType'' ([BTyVar], [BareType])
s(RAllP PVU BTyCon BTyVar
_ BareType
t) =
  ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' ([BTyVar], [BareType])
s BareType
t
simplifyBareType'' ([BTyVar], [BareType])
s (RAllE Symbol
_ BareType
_ BareType
t) =
  ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' ([BTyVar], [BareType])
s BareType
t
simplifyBareType'' ([BTyVar], [BareType])
s (REx Symbol
_ BareType
_ BareType
t) =
  ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' ([BTyVar], [BareType])
s BareType
t
simplifyBareType'' ([BTyVar], [BareType])
s (RRTy [(Symbol, BareType)]
_ RReft
_ Oblig
_ BareType
t) =
  ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' ([BTyVar], [BareType])
s BareType
t

simplifyBareType'' ([BTyVar]
tvs, [BareType]
cls) (RFun Symbol
_ BareType
i BareType
o RReft
_)
  | BareType -> Bool
forall c t t1. TyConable c => RType c t t1 -> Bool
isClassType BareType
i = ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' ([BTyVar]
tvs, BareType
i BareType -> [BareType] -> [BareType]
forall a. a -> [a] -> [a]
: [BareType]
cls) BareType
o
simplifyBareType'' ([BTyVar]
tvs, [BareType]
cls) (RAllT RTVU BTyCon BTyVar
tv BareType
t RReft
_) =
  ([BTyVar], [BareType]) -> BareType -> Simpl Type
simplifyBareType'' (RTVU BTyCon BTyVar -> BTyVar
forall tv s. RTVar tv s -> tv
ty_var_value RTVU BTyCon BTyVar
tv BTyVar -> [BTyVar] -> [BTyVar]
forall a. a -> [a] -> [a]
: [BTyVar]
tvs, [BareType]
cls) BareType
t

simplifyBareType'' ([BTyVar]
tvs, [BareType]
cls) BareType
t =
  [TyVarBndr] -> [Type] -> Type -> Type
ForallT (Name -> TyVarBndr
PlainTV (Name -> TyVarBndr) -> (BTyVar -> Name) -> BTyVar -> TyVarBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BTyVar -> Name
forall s. Symbolic s => s -> Name
symbolName (BTyVar -> TyVarBndr) -> [BTyVar] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BTyVar] -> [BTyVar]
forall a. [a] -> [a]
reverse [BTyVar]
tvs)
    ([Type] -> Type -> Type) -> Simpl [Type] -> Simpl (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BareType -> Simpl Type) -> [BareType] -> Simpl [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BareType -> Simpl Type
simplifyBareType' ([BareType] -> [BareType]
forall a. [a] -> [a]
reverse [BareType]
cls)
    Simpl (Type -> Type) -> Simpl Type -> Simpl Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BareType -> Simpl Type
simplifyBareType' BareType
t


data Simpl a = Simplified a
             | FoundExprArg SrcSpan
             | FoundHole
               deriving (a -> Simpl b -> Simpl a
(a -> b) -> Simpl a -> Simpl b
(forall a b. (a -> b) -> Simpl a -> Simpl b)
-> (forall a b. a -> Simpl b -> Simpl a) -> Functor Simpl
forall a b. a -> Simpl b -> Simpl a
forall a b. (a -> b) -> Simpl a -> Simpl b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Simpl b -> Simpl a
$c<$ :: forall a b. a -> Simpl b -> Simpl a
fmap :: (a -> b) -> Simpl a -> Simpl b
$cfmap :: forall a b. (a -> b) -> Simpl a -> Simpl b
Functor)

instance Applicative Simpl where
  pure :: a -> Simpl a
pure = a -> Simpl a
forall a. a -> Simpl a
Simplified

  Simplified   a -> b
f <*> :: Simpl (a -> b) -> Simpl a -> Simpl b
<*> Simplified   a
x = b -> Simpl b
forall a. a -> Simpl a
Simplified (b -> Simpl b) -> b -> Simpl b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
  Simpl (a -> b)
_              <*> FoundExprArg SrcSpan
l = SrcSpan -> Simpl b
forall a. SrcSpan -> Simpl a
FoundExprArg SrcSpan
l
  Simpl (a -> b)
_              <*> Simpl a
FoundHole      = Simpl b
forall a. Simpl a
FoundHole
  FoundExprArg SrcSpan
l <*> Simpl a
_              = SrcSpan -> Simpl b
forall a. SrcSpan -> Simpl a
FoundExprArg SrcSpan
l
  Simpl (a -> b)
FoundHole      <*> Simpl a
_              = Simpl b
forall a. Simpl a
FoundHole

instance Monad Simpl where
  return :: a -> Simpl a
return = a -> Simpl a
forall a. a -> Simpl a
Simplified

  Simplified   a
x >>= :: Simpl a -> (a -> Simpl b) -> Simpl b
>>= a -> Simpl b
f = a -> Simpl b
f a
x
  FoundExprArg SrcSpan
l >>= a -> Simpl b
_ = SrcSpan -> Simpl b
forall a. SrcSpan -> Simpl a
FoundExprArg SrcSpan
l
  Simpl a
FoundHole      >>= a -> Simpl b
_ = Simpl b
forall a. Simpl a
FoundHole

filterExprArgs :: [Simpl a] -> [Simpl a]
filterExprArgs :: [Simpl a] -> [Simpl a]
filterExprArgs = (Simpl a -> Bool) -> [Simpl a] -> [Simpl a]
forall a. (a -> Bool) -> [a] -> [a]
filter Simpl a -> Bool
forall a. Simpl a -> Bool
check
  where
    check :: Simpl a -> Bool
check (FoundExprArg SrcSpan
_) = Bool
False
    check Simpl a
_ = Bool
True

--------------------------------------------------------------------------------
-- QuasiQuoter Annotations -----------------------------------------------------
--------------------------------------------------------------------------------

newtype LiquidQuote = LiquidQuote { LiquidQuote -> BPspec
liquidQuoteSpec :: BPspec }
                      deriving (Typeable LiquidQuote
DataType
Constr
Typeable LiquidQuote
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> LiquidQuote -> c LiquidQuote)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c LiquidQuote)
-> (LiquidQuote -> Constr)
-> (LiquidQuote -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c LiquidQuote))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c LiquidQuote))
-> ((forall b. Data b => b -> b) -> LiquidQuote -> LiquidQuote)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r)
-> (forall u. (forall d. Data d => d -> u) -> LiquidQuote -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> LiquidQuote -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote)
-> Data LiquidQuote
LiquidQuote -> DataType
LiquidQuote -> Constr
(forall b. Data b => b -> b) -> LiquidQuote -> LiquidQuote
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LiquidQuote -> c LiquidQuote
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LiquidQuote
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> LiquidQuote -> u
forall u. (forall d. Data d => d -> u) -> LiquidQuote -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LiquidQuote
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LiquidQuote -> c LiquidQuote
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LiquidQuote)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LiquidQuote)
$cLiquidQuote :: Constr
$tLiquidQuote :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
gmapMp :: (forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
gmapM :: (forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LiquidQuote -> m LiquidQuote
gmapQi :: Int -> (forall d. Data d => d -> u) -> LiquidQuote -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> LiquidQuote -> u
gmapQ :: (forall d. Data d => d -> u) -> LiquidQuote -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> LiquidQuote -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LiquidQuote -> r
gmapT :: (forall b. Data b => b -> b) -> LiquidQuote -> LiquidQuote
$cgmapT :: (forall b. Data b => b -> b) -> LiquidQuote -> LiquidQuote
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LiquidQuote)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LiquidQuote)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c LiquidQuote)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LiquidQuote)
dataTypeOf :: LiquidQuote -> DataType
$cdataTypeOf :: LiquidQuote -> DataType
toConstr :: LiquidQuote -> Constr
$ctoConstr :: LiquidQuote -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LiquidQuote
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LiquidQuote
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LiquidQuote -> c LiquidQuote
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LiquidQuote -> c LiquidQuote
$cp1Data :: Typeable LiquidQuote
Data, Typeable)

--------------------------------------------------------------------------------
-- Template Haskell Utility Functions ------------------------------------------
--------------------------------------------------------------------------------

locSourcePos :: Loc -> SourcePos
locSourcePos :: Loc -> SourcePos
locSourcePos Loc
loc =
  String -> Int -> Int -> SourcePos
newPos (Loc -> String
loc_filename Loc
loc) ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
loc_start Loc
loc) ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
loc_start Loc
loc)

dataToExpQ' :: Data a => a -> Q Exp
dataToExpQ' :: a -> Q Exp
dataToExpQ' = (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
dataToExpQ (Maybe (Q Exp) -> b -> Maybe (Q Exp)
forall a b. a -> b -> a
const Maybe (Q Exp)
forall a. Maybe a
Nothing (b -> Maybe (Q Exp))
-> (Text -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Text -> Maybe (Q Exp)
textToExpQ)

textToExpQ :: T.Text -> Maybe ExpQ
textToExpQ :: Text -> Maybe (Q Exp)
textToExpQ Text
text = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE 'T.pack Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (Text -> String
T.unpack Text
text)

extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
extQ :: (a -> q) -> (b -> q) -> a -> q
extQ a -> q
f b -> q
g a
a = q -> (b -> q) -> Maybe b -> q
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> q
f a
a) b -> q
g (a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a)