{- |
  Module      :  $Header$
  Description :  Deriving instances
  Copyright   :  (c) 2016        Finn Teegen
  License     :  BSD-3-clause

  Maintainer  :  bjp@informatik.uni-kiel.de
  Stability   :  experimental
  Portability :  portable

  TODO
-}
{-# LANGUAGE CPP #-}
module Transformations.Derive (derive) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative      ((<$>))
#endif
import Control.Monad               (replicateM)
import qualified Control.Monad.State as S (State, evalState, gets, modify)
import           Data.List         (intercalate, intersperse)
import           Data.Maybe        (fromJust, isJust)
import qualified Data.Set   as Set (deleteMin, union)

import Curry.Base.Ident
import Curry.Base.SpanInfo
import Curry.Syntax

import Base.CurryTypes (fromPredType)
import Base.Messages (internalError)
import Base.Types
import Base.TypeSubst (instanceType)
import Base.Typing (typeOf)
import Base.Utils (snd3, mapAccumM)

import Env.Instance
import Env.OpPrec
import Env.TypeConstructor
import Env.Value

data DVState = DVState
  { DVState -> ModuleIdent
moduleIdent :: ModuleIdent
  , DVState -> TCEnv
tyConsEnv   :: TCEnv
  , DVState -> ValueEnv
valueEnv    :: ValueEnv
  , DVState -> InstEnv
instEnv     :: InstEnv
  , DVState -> OpPrecEnv
opPrecEnv   :: OpPrecEnv
  , DVState -> Integer
nextId      :: Integer
  }

type DVM = S.State DVState

derive :: TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Module PredType
       -> Module PredType
derive :: TCEnv
-> ValueEnv
-> InstEnv
-> OpPrecEnv
-> Module PredType
-> Module PredType
derive tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv inEnv :: InstEnv
inEnv pEnv :: OpPrecEnv
pEnv (Module spi :: SpanInfo
spi li :: LayoutInfo
li ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl PredType]
ds) = SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl PredType]
-> Module PredType
forall a.
SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi LayoutInfo
li [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
es [ImportDecl]
is ([Decl PredType] -> Module PredType)
-> [Decl PredType] -> Module PredType
forall a b. (a -> b) -> a -> b
$
  [Decl PredType]
ds [Decl PredType] -> [Decl PredType] -> [Decl PredType]
forall a. [a] -> [a] -> [a]
++ [[Decl PredType]] -> [Decl PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (State DVState [[Decl PredType]] -> DVState -> [[Decl PredType]]
forall s a. State s a -> s -> a
S.evalState ([Decl PredType] -> State DVState [[Decl PredType]]
deriveAllInstances [Decl PredType]
tds) DVState
initState)
  where tds :: [Decl PredType]
tds = (Decl PredType -> Bool) -> [Decl PredType] -> [Decl PredType]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl PredType -> Bool
forall a. Decl a -> Bool
isTypeDecl [Decl PredType]
ds
        initState :: DVState
initState = ModuleIdent
-> TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Integer -> DVState
DVState ModuleIdent
m TCEnv
tcEnv ValueEnv
vEnv InstEnv
inEnv OpPrecEnv
pEnv 1

getModuleIdent :: DVM ModuleIdent
getModuleIdent :: DVM ModuleIdent
getModuleIdent = (DVState -> ModuleIdent) -> DVM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DVState -> ModuleIdent
moduleIdent

getTyConsEnv :: DVM TCEnv
getTyConsEnv :: DVM TCEnv
getTyConsEnv = (DVState -> TCEnv) -> DVM TCEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DVState -> TCEnv
tyConsEnv

getValueEnv :: DVM ValueEnv
getValueEnv :: DVM ValueEnv
getValueEnv = (DVState -> ValueEnv) -> DVM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DVState -> ValueEnv
valueEnv

getInstEnv :: DVM InstEnv
getInstEnv :: DVM InstEnv
getInstEnv = (DVState -> InstEnv) -> DVM InstEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DVState -> InstEnv
instEnv

getPrecEnv :: DVM OpPrecEnv
getPrecEnv :: DVM OpPrecEnv
getPrecEnv = (DVState -> OpPrecEnv) -> DVM OpPrecEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DVState -> OpPrecEnv
opPrecEnv

getNextId :: DVM Integer
getNextId :: DVM Integer
getNextId = do
  Integer
nid <- (DVState -> Integer) -> DVM Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DVState -> Integer
nextId
  (DVState -> DVState) -> StateT DVState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DVState -> DVState) -> StateT DVState Identity ())
-> (DVState -> DVState) -> StateT DVState Identity ()
forall a b. (a -> b) -> a -> b
$ \s :: DVState
s -> DVState
s { nextId :: Integer
nextId = Integer -> Integer
forall a. Enum a => a -> a
succ Integer
nid }
  Integer -> DVM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
nid

-- TODO: Comment (here and below)

type ConstrInfo = (Int, QualIdent, Maybe [Ident], [Type])

deriveAllInstances :: [Decl PredType] -> DVM [[Decl PredType]]
deriveAllInstances :: [Decl PredType] -> State DVState [[Decl PredType]]
deriveAllInstances ds :: [Decl PredType]
ds = do
  [[Decl PredType]]
derived <- (Decl PredType -> StateT DVState Identity [Decl PredType])
-> [Decl PredType] -> State DVState [[Decl PredType]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> StateT DVState Identity [Decl PredType]
deriveInstances [Decl PredType]
ds
  InstEnv
inst <- DVM InstEnv
getInstEnv
  ModuleIdent
mid <- DVM ModuleIdent
getModuleIdent
  let dds :: [Decl PredType]
dds = (Decl PredType -> Bool) -> [Decl PredType] -> [Decl PredType]
forall a. (a -> Bool) -> [a] -> [a]
filter (InstEnv -> ModuleIdent -> Decl PredType -> Bool
hasDataInstance InstEnv
inst ModuleIdent
mid) [Decl PredType]
ds
  [Decl PredType]
datains <- (Decl PredType -> StateT DVState Identity (Decl PredType))
-> [Decl PredType] -> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> StateT DVState Identity (Decl PredType)
deriveDataInstance [Decl PredType]
dds
  [[Decl PredType]] -> State DVState [[Decl PredType]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType]
datains[Decl PredType] -> [[Decl PredType]] -> [[Decl PredType]]
forall a. a -> [a] -> [a]
:[[Decl PredType]]
derived)

-- If we ever entered a data instance for this datatype into the instance
-- environment, we can safely derive a data instance
hasDataInstance :: InstEnv -> ModuleIdent -> Decl PredType -> Bool
hasDataInstance :: InstEnv -> ModuleIdent -> Decl PredType -> Bool
hasDataInstance inst :: InstEnv
inst mid :: ModuleIdent
mid (DataDecl    _ tc :: Ident
tc _ _ _) =
  Bool
-> ((ModuleIdent, PredSet, [(Ident, Int)]) -> Bool)
-> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\(mid' :: ModuleIdent
mid', _, _) -> ModuleIdent
mid ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent
mid') (Maybe (ModuleIdent, PredSet, [(Ident, Int)]) -> Bool)
-> Maybe (ModuleIdent, PredSet, [(Ident, Int)]) -> Bool
forall a b. (a -> b) -> a -> b
$
    InstIdent
-> InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
lookupInstInfo (QualIdent
qDataId, ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
mid Ident
tc) InstEnv
inst
hasDataInstance inst :: InstEnv
inst mid :: ModuleIdent
mid (NewtypeDecl _ tc :: Ident
tc _ _ _) =
  Bool
-> ((ModuleIdent, PredSet, [(Ident, Int)]) -> Bool)
-> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\(mid' :: ModuleIdent
mid', _, _) -> ModuleIdent
mid ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleIdent
mid') (Maybe (ModuleIdent, PredSet, [(Ident, Int)]) -> Bool)
-> Maybe (ModuleIdent, PredSet, [(Ident, Int)]) -> Bool
forall a b. (a -> b) -> a -> b
$
    InstIdent
-> InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
lookupInstInfo (QualIdent
qDataId, ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
mid Ident
tc) InstEnv
inst
hasDataInstance _       _   _                     =
  Bool
False

deriveDataInstance :: Decl PredType -> DVM (Decl PredType)
deriveDataInstance :: Decl PredType -> StateT DVState Identity (Decl PredType)
deriveDataInstance (DataDecl    p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs _ _) =
  [Decl PredType] -> Decl PredType
forall a. [a] -> a
head ([Decl PredType] -> Decl PredType)
-> StateT DVState Identity [Decl PredType]
-> StateT DVState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decl PredType -> StateT DVState Identity [Decl PredType]
deriveInstances (SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs [] [QualIdent
qDataId])
deriveDataInstance (NewtypeDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs _ _) =
  Decl PredType -> StateT DVState Identity (Decl PredType)
deriveDataInstance (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs [] []
deriveDataInstance _                          =
  String -> StateT DVState Identity (Decl PredType)
forall a. String -> a
internalError "Derive.deriveDataInstance: No DataDel"

-- An instance declaration is created for each type class of a deriving clause.
-- Newtype declaration are simply treated as data declarations.

deriveInstances :: Decl PredType -> DVM [Decl PredType]
deriveInstances :: Decl PredType -> StateT DVState Identity [Decl PredType]
deriveInstances (DataDecl    _ tc :: Ident
tc tvs :: [Ident]
tvs _ clss :: [QualIdent]
clss) = do
  ModuleIdent
m <- DVM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- DVM TCEnv
getTyConsEnv
  let otc :: QualIdent
otc = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
tc
      cis :: [ConstrInfo]
cis = ModuleIdent -> QualIdent -> TCEnv -> [ConstrInfo]
constructors ModuleIdent
m QualIdent
otc TCEnv
tcEnv
  (QualIdent -> StateT DVState Identity (Decl PredType))
-> [QualIdent] -> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (QualIdent
-> [Ident]
-> [ConstrInfo]
-> QualIdent
-> StateT DVState Identity (Decl PredType)
deriveInstance QualIdent
otc [Ident]
tvs [ConstrInfo]
cis) [QualIdent]
clss
deriveInstances (NewtypeDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs _ clss :: [QualIdent]
clss) =
  Decl PredType -> StateT DVState Identity [Decl PredType]
deriveInstances (Decl PredType -> StateT DVState Identity [Decl PredType])
-> Decl PredType -> StateT DVState Identity [Decl PredType]
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs [] [QualIdent]
clss
deriveInstances _                             = [Decl PredType] -> StateT DVState Identity [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return []

deriveInstance :: QualIdent -> [Ident] -> [ConstrInfo] -> QualIdent
               -> DVM (Decl PredType)
deriveInstance :: QualIdent
-> [Ident]
-> [ConstrInfo]
-> QualIdent
-> StateT DVState Identity (Decl PredType)
deriveInstance tc :: QualIdent
tc tvs :: [Ident]
tvs cis :: [ConstrInfo]
cis cls :: QualIdent
cls = do
  InstEnv
inEnv <- DVM InstEnv
getInstEnv
  let ps :: PredSet
ps = (ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet
forall a b c. (a, b, c) -> b
snd3 ((ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet)
-> (ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet
forall a b. (a -> b) -> a -> b
$ Maybe (ModuleIdent, PredSet, [(Ident, Int)])
-> (ModuleIdent, PredSet, [(Ident, Int)])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (ModuleIdent, PredSet, [(Ident, Int)])
 -> (ModuleIdent, PredSet, [(Ident, Int)]))
-> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
-> (ModuleIdent, PredSet, [(Ident, Int)])
forall a b. (a -> b) -> a -> b
$ InstIdent
-> InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
lookupInstInfo (QualIdent
cls, QualIdent
tc) InstEnv
inEnv
      ty :: Type
ty = Type -> [Type] -> Type
applyType (QualIdent -> Type
TypeConstructor QualIdent
tc) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$
             Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
tvs) ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ (Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
TypeVariable [0 ..]
      QualTypeExpr _ cx :: Context
cx inst :: TypeExpr
inst = [Ident] -> PredType -> QualTypeExpr
fromPredType [Ident]
tvs (PredType -> QualTypeExpr) -> PredType -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType PredSet
ps Type
ty
  [Decl PredType]
ds <- QualIdent
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveMethods QualIdent
cls Type
ty [ConstrInfo]
cis PredSet
ps
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl PredType]
-> Decl PredType
forall a.
SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl a]
-> Decl a
InstanceDecl SpanInfo
NoSpanInfo LayoutInfo
WhitespaceLayout Context
cx QualIdent
cls TypeExpr
inst [Decl PredType]
ds

-- Note: The methods and arities of the generated instance declarations have to
-- correspond to the methods and arities entered previously into the instance
-- environment (see instance check).

deriveMethods :: QualIdent -> Type -> [ConstrInfo] -> PredSet
              -> DVM [Decl PredType]
deriveMethods :: QualIdent
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveMethods cls :: QualIdent
cls
  | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qEqId      = Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveEqMethods
  | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qOrdId     = Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveOrdMethods
  | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qEnumId    = Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveEnumMethods
  | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qBoundedId = Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveBoundedMethods
  | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qReadId    = Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveReadMethods
  | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qShowId    = Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveShowMethods
  | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qDataId    = Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveDataMethods
  | Bool
otherwise         = String
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
forall a. String -> a
internalError (String
 -> Type
 -> [ConstrInfo]
 -> PredSet
 -> StateT DVState Identity [Decl PredType])
-> String
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
forall a b. (a -> b) -> a -> b
$ "Derive.deriveMethods: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
cls

-- Binary Operators:

type BinOpExpr = Int
              -> [Expression PredType]
              -> Int
              -> [Expression PredType]
              -> Expression PredType

deriveBinOp :: QualIdent -> Ident -> BinOpExpr -> Type -> [ConstrInfo]
            -> PredSet -> DVM (Decl PredType)
deriveBinOp :: QualIdent
-> Ident
-> BinOpExpr
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveBinOp cls :: QualIdent
cls op :: Ident
op expr :: BinOpExpr
expr ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
cls Type
ty Ident
op
  [Equation PredType]
eqs <- ([ConstrInfo] -> StateT DVState Identity (Equation PredType))
-> [[ConstrInfo]] -> StateT DVState Identity [Equation PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Ident
-> BinOpExpr
-> Type
-> [ConstrInfo]
-> StateT DVState Identity (Equation PredType)
deriveBinOpEquation Ident
op BinOpExpr
expr Type
ty) ([[ConstrInfo]] -> StateT DVState Identity [Equation PredType])
-> [[ConstrInfo]] -> StateT DVState Identity [Equation PredType]
forall a b. (a -> b) -> a -> b
$ [[ConstrInfo]] -> [[ConstrInfo]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[ConstrInfo]
cis, [ConstrInfo]
cis]
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
NoSpanInfo PredType
pty Ident
op ([Equation PredType] -> Decl PredType)
-> [Equation PredType] -> Decl PredType
forall a b. (a -> b) -> a -> b
$
    if [Equation PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Equation PredType]
eqs
      then [SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
op [] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$
        Type -> Expression PredType
preludeFailed (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty]
      else [Equation PredType]
eqs

deriveBinOpEquation :: Ident -> BinOpExpr -> Type -> [ConstrInfo]
                    -> DVM (Equation PredType)
deriveBinOpEquation :: Ident
-> BinOpExpr
-> Type
-> [ConstrInfo]
-> StateT DVState Identity (Equation PredType)
deriveBinOpEquation op :: Ident
op expr :: BinOpExpr
expr ty :: Type
ty [(i1 :: Int
i1, c1 :: QualIdent
c1, _, tys1 :: [Type]
tys1), (i2 :: Int
i2, c2 :: QualIdent
c2, _, tys2 :: [Type]
tys2)] = do
  [(PredType, Ident)]
vs1 <- (Type -> StateT DVState Identity (PredType, Ident))
-> [Type] -> StateT DVState Identity [(PredType, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> (Type -> Type)
-> Type
-> StateT DVState Identity (PredType, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) [Type]
tys1
  [(PredType, Ident)]
vs2 <- (Type -> StateT DVState Identity (PredType, Ident))
-> [Type] -> StateT DVState Identity [(PredType, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> (Type -> Type)
-> Type
-> StateT DVState Identity (PredType, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) [Type]
tys2
  let pat1 :: Pattern PredType
pat1 = PredType -> QualIdent -> [(PredType, Ident)] -> Pattern PredType
forall a. a -> QualIdent -> [(a, Ident)] -> Pattern a
constrPattern PredType
pty QualIdent
c1 [(PredType, Ident)]
vs1
      pat2 :: Pattern PredType
pat2 = PredType -> QualIdent -> [(PredType, Ident)] -> Pattern PredType
forall a. a -> QualIdent -> [(a, Ident)] -> Pattern a
constrPattern PredType
pty QualIdent
c2 [(PredType, Ident)]
vs2
      es1 :: [Expression PredType]
es1 = ((PredType, Ident) -> Expression PredType)
-> [(PredType, Ident)] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar) [(PredType, Ident)]
vs1
      es2 :: [Expression PredType]
es2 = ((PredType, Ident) -> Expression PredType)
-> [(PredType, Ident)] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar) [(PredType, Ident)]
vs2
  Equation PredType -> StateT DVState Identity (Equation PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Equation PredType -> StateT DVState Identity (Equation PredType))
-> Equation PredType -> StateT DVState Identity (Equation PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
op [Pattern PredType
pat1, Pattern PredType
pat2] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$ BinOpExpr
expr Int
i1 [Expression PredType]
es1 Int
i2 [Expression PredType]
es2
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty
deriveBinOpEquation _ _ _ _ = String -> StateT DVState Identity (Equation PredType)
forall a. String -> a
internalError "Derive.deriveBinOpEquation"

-- Equality:

deriveEqMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveEqMethods :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveEqMethods ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = [StateT DVState Identity (Decl PredType)]
-> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [QualIdent
-> Ident
-> BinOpExpr
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveBinOp QualIdent
qEqId Ident
eqOpId BinOpExpr
eqOpExpr Type
ty [ConstrInfo]
cis PredSet
ps]

eqOpExpr :: BinOpExpr
eqOpExpr :: BinOpExpr
eqOpExpr i1 :: Int
i1 es1 :: [Expression PredType]
es1 i2 :: Int
i2 es2 :: [Expression PredType]
es2
  | Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i2  = if [Expression PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression PredType]
es1 then Expression PredType
prelTrue
                            else (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Expression PredType -> Expression PredType -> Expression PredType
prelAnd ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType]
-> [Expression PredType]
-> [Expression PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression PredType -> Expression PredType -> Expression PredType
prelEq [Expression PredType]
es1 [Expression PredType]
es2
  | Bool
otherwise = Expression PredType
prelFalse

-- Data:

deriveDataMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveDataMethods :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveDataMethods ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = [StateT DVState Identity (Decl PredType)]
-> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [ QualIdent
-> Ident
-> BinOpExpr
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveBinOp QualIdent
qDataId Ident
dataEqId BinOpExpr
dataEqOpExpr Type
ty [ConstrInfo]
cis PredSet
ps
  , Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveAValue Type
ty [ConstrInfo]
cis PredSet
ps]

dataEqOpExpr :: BinOpExpr
dataEqOpExpr :: BinOpExpr
dataEqOpExpr i1 :: Int
i1 es1 :: [Expression PredType]
es1 i2 :: Int
i2 es2 :: [Expression PredType]
es2
  | Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i2  = if [Expression PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression PredType]
es1 then Expression PredType
prelTrue
                            else (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Expression PredType -> Expression PredType -> Expression PredType
prelAnd ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType]
-> [Expression PredType]
-> [Expression PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression PredType -> Expression PredType -> Expression PredType
prelDataEq [Expression PredType]
es1 [Expression PredType]
es2
  | Bool
otherwise = Expression PredType
prelFalse

deriveAValue :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveAValue :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveAValue ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qDataId Type
ty Ident
aValueId
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
NoSpanInfo PredType
pty Ident
aValueId ([Equation PredType] -> Decl PredType)
-> [Equation PredType] -> Decl PredType
forall a b. (a -> b) -> a -> b
$
    if [ConstrInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstrInfo]
cis
      then [SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
aValueId [] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$ Type -> Expression PredType
preludeFailed (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty]
      else (ConstrInfo -> Equation PredType)
-> [ConstrInfo] -> [Equation PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> ConstrInfo -> Equation PredType
aValueEquation Type
ty) [ConstrInfo]
cis

aValueEquation :: Type -> ConstrInfo -> Equation PredType
aValueEquation :: Type -> ConstrInfo -> Equation PredType
aValueEquation ty :: Type
ty (arity :: Int
arity, cns :: QualIdent
cns, _, tys :: [Type]
tys)
  | Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 = SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
aValueId [] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$ Type -> PredType
predType (Type -> PredType) -> Expression Type -> Expression PredType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  (Expression Type -> Expression Type -> Expression Type)
-> Expression Type -> [Expression Type] -> Expression Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (SpanInfo -> Expression Type -> Expression Type -> Expression Type
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
                    (SpanInfo -> Type -> QualIdent -> Expression Type
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo Type
constrType QualIdent
cns)
                    ((Type -> Expression Type) -> [Type] -> [Expression Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Expression Type
forall a. a -> Expression a
mkAValue [Type]
tys')
  | Bool
otherwise  = String -> Equation PredType
forall a. String -> a
internalError "Derive.aValueEquation: negative arity"
  where
    constrType :: Type
constrType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow (Type -> Type
instType Type
ty) [Type]
tys'
    mkAValue :: a -> Expression a
mkAValue argTy :: a
argTy = SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo a
argTy QualIdent
qAValueId
    tys' :: [Type]
tys' = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
instType [Type]
tys

-- Ordering:

deriveOrdMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveOrdMethods :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveOrdMethods ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = [StateT DVState Identity (Decl PredType)]
-> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [QualIdent
-> Ident
-> BinOpExpr
-> Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveBinOp QualIdent
qOrdId Ident
leqOpId BinOpExpr
leqOpExpr Type
ty [ConstrInfo]
cis PredSet
ps]

leqOpExpr :: BinOpExpr
leqOpExpr :: BinOpExpr
leqOpExpr i1 :: Int
i1 es1 :: [Expression PredType]
es1 i2 :: Int
i2 es2 :: [Expression PredType]
es2
  | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i2   = Expression PredType
prelTrue
  | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i2   = Expression PredType
prelFalse
  | Bool
otherwise = if [Expression PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression PredType]
es1 then Expression PredType
prelTrue
                            else (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Expression PredType -> Expression PredType -> Expression PredType
prelOr ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (Int -> Expression PredType) -> [Int] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Expression PredType
innerAnd [0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
  where n :: Int
n = [Expression PredType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression PredType]
es1
        innerAnd :: Int -> Expression PredType
innerAnd i :: Int
i = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Expression PredType -> Expression PredType -> Expression PredType
prelAnd ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (Int -> Expression PredType) -> [Int] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Expression PredType
innerOp Int
i) [0 .. Int
i]
        innerOp :: Int -> Int -> Expression PredType
innerOp i :: Int
i j :: Int
j | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 = Expression PredType -> Expression PredType -> Expression PredType
prelLeq ([Expression PredType]
es1 [Expression PredType] -> Int -> Expression PredType
forall a. [a] -> Int -> a
!! Int
j) ([Expression PredType]
es2 [Expression PredType] -> Int -> Expression PredType
forall a. [a] -> Int -> a
!! Int
j)
                    | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i     = Expression PredType -> Expression PredType -> Expression PredType
prelLt  ([Expression PredType]
es1 [Expression PredType] -> Int -> Expression PredType
forall a. [a] -> Int -> a
!! Int
j) ([Expression PredType]
es2 [Expression PredType] -> Int -> Expression PredType
forall a. [a] -> Int -> a
!! Int
j)
                    | Bool
otherwise  = Expression PredType -> Expression PredType -> Expression PredType
prelEq  ([Expression PredType]
es1 [Expression PredType] -> Int -> Expression PredType
forall a. [a] -> Int -> a
!! Int
j) ([Expression PredType]
es2 [Expression PredType] -> Int -> Expression PredType
forall a. [a] -> Int -> a
!! Int
j)

-- Enumerations:

deriveEnumMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveEnumMethods :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveEnumMethods ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = [StateT DVState Identity (Decl PredType)]
-> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [ Ident
-> Type
-> [ConstrInfo]
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveSuccOrPred Ident
succId Type
ty [ConstrInfo]
cis ([ConstrInfo] -> [ConstrInfo]
forall a. [a] -> [a]
tail [ConstrInfo]
cis) PredSet
ps
  , Ident
-> Type
-> [ConstrInfo]
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveSuccOrPred Ident
predId Type
ty ([ConstrInfo] -> [ConstrInfo]
forall a. [a] -> [a]
tail [ConstrInfo]
cis) [ConstrInfo]
cis PredSet
ps
  , Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveToEnum Type
ty [ConstrInfo]
cis PredSet
ps
  , Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveFromEnum Type
ty [ConstrInfo]
cis PredSet
ps
  , Type
-> ConstrInfo -> PredSet -> StateT DVState Identity (Decl PredType)
deriveEnumFrom Type
ty ([ConstrInfo] -> ConstrInfo
forall a. [a] -> a
last [ConstrInfo]
cis) PredSet
ps
  , Type
-> ConstrInfo
-> ConstrInfo
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveEnumFromThen Type
ty ([ConstrInfo] -> ConstrInfo
forall a. [a] -> a
head [ConstrInfo]
cis) ([ConstrInfo] -> ConstrInfo
forall a. [a] -> a
last [ConstrInfo]
cis) PredSet
ps
  ]

deriveSuccOrPred :: Ident -> Type -> [ConstrInfo] -> [ConstrInfo] -> PredSet
                 -> DVM (Decl PredType)
deriveSuccOrPred :: Ident
-> Type
-> [ConstrInfo]
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveSuccOrPred f :: Ident
f ty :: Type
ty cis1 :: [ConstrInfo]
cis1 cis2 :: [ConstrInfo]
cis2 ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qEnumId Type
ty Ident
f
  SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
NoSpanInfo PredType
pty Ident
f ([Equation PredType] -> Decl PredType)
-> StateT DVState Identity [Equation PredType]
-> StateT DVState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    if [Equation PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Equation PredType]
eqs
      then do
        (PredType, Ident)
v <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> Type -> StateT DVState Identity (PredType, Ident)
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty
        [Equation PredType] -> StateT DVState Identity [Equation PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return [SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
f [(PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
v] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$
          Type -> Expression PredType
preludeFailed (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty]
      else [Equation PredType] -> StateT DVState Identity [Equation PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return [Equation PredType]
eqs
  where eqs :: [Equation PredType]
eqs = (ConstrInfo -> ConstrInfo -> Equation PredType)
-> [ConstrInfo] -> [ConstrInfo] -> [Equation PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Ident -> Type -> ConstrInfo -> ConstrInfo -> Equation PredType
succOrPredEquation Ident
f Type
ty) [ConstrInfo]
cis1 [ConstrInfo]
cis2

succOrPredEquation :: Ident -> Type -> ConstrInfo -> ConstrInfo
                   -> Equation PredType
succOrPredEquation :: Ident -> Type -> ConstrInfo -> ConstrInfo -> Equation PredType
succOrPredEquation f :: Ident
f ty :: Type
ty (_, c1 :: QualIdent
c1, _, _) (_, c2 :: QualIdent
c2, _, _) =
  SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
f [SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
c1 []] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$
    SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
pty QualIdent
c2
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty

deriveToEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveToEnum :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveToEnum ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qEnumId Type
ty Ident
toEnumId
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
NoSpanInfo PredType
pty Ident
toEnumId [Equation PredType]
eqs
  where eqs :: [Equation PredType]
eqs = (Integer -> ConstrInfo -> Equation PredType)
-> [Integer] -> [ConstrInfo] -> [Equation PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Type -> Integer -> ConstrInfo -> Equation PredType
toEnumEquation Type
ty) [0 ..] [ConstrInfo]
cis

toEnumEquation :: Type -> Integer -> ConstrInfo -> Equation PredType
toEnumEquation :: Type -> Integer -> ConstrInfo -> Equation PredType
toEnumEquation ty :: Type
ty i :: Integer
i (_, c :: QualIdent
c, _, _) =
  SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
toEnumId
    [SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo (Type -> PredType
predType Type
intType) (Integer -> Literal
Int Integer
i)] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$
    SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty) QualIdent
c

deriveFromEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveFromEnum :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveFromEnum ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qEnumId Type
ty Ident
fromEnumId
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
NoSpanInfo PredType
pty Ident
fromEnumId [Equation PredType]
eqs
  where eqs :: [Equation PredType]
eqs = (ConstrInfo -> Integer -> Equation PredType)
-> [ConstrInfo] -> [Integer] -> [Equation PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Type -> ConstrInfo -> Integer -> Equation PredType
fromEnumEquation Type
ty) [ConstrInfo]
cis [0 ..]

fromEnumEquation :: Type -> ConstrInfo -> Integer -> Equation PredType
fromEnumEquation :: Type -> ConstrInfo -> Integer -> Equation PredType
fromEnumEquation ty :: Type
ty (_, c :: QualIdent
c, _, _) i :: Integer
i =
  SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
fromEnumId [SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
c []] (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$
    SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo (Type -> PredType
predType Type
intType) (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int Integer
i
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty

deriveEnumFrom :: Type -> ConstrInfo -> PredSet -> DVM (Decl PredType)
deriveEnumFrom :: Type
-> ConstrInfo -> PredSet -> StateT DVState Identity (Decl PredType)
deriveEnumFrom ty :: Type
ty (_, c :: QualIdent
c, _, _) ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qEnumId Type
ty Ident
enumFromId
  (PredType, Ident)
v <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> Type -> StateT DVState Identity (PredType, Ident)
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
NoSpanInfo PredType
pty Ident
enumFromId
    [(PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
v] (Expression PredType -> Decl PredType)
-> Expression PredType -> Decl PredType
forall a b. (a -> b) -> a -> b
$
    (PredType, Ident) -> QualIdent -> Expression PredType
enumFromExpr (PredType, Ident)
v QualIdent
c

enumFromExpr :: (PredType, Ident) -> QualIdent -> Expression PredType
enumFromExpr :: (PredType, Ident) -> QualIdent -> Expression PredType
enumFromExpr v :: (PredType, Ident)
v c :: QualIdent
c = Expression PredType -> Expression PredType -> Expression PredType
prelEnumFromTo ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo ((PredType, Ident) -> PredType
forall a b. (a, b) -> a
fst (PredType, Ident)
v) QualIdent
c

deriveEnumFromThen :: Type -> ConstrInfo -> ConstrInfo -> PredSet
                   -> DVM (Decl PredType)
deriveEnumFromThen :: Type
-> ConstrInfo
-> ConstrInfo
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveEnumFromThen ty :: Type
ty (_, c1 :: QualIdent
c1, _, _) (_, c2 :: QualIdent
c2, _, _) ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qEnumId Type
ty Ident
enumFromId
  [(PredType, Ident)]
vs  <- Int
-> StateT DVState Identity (PredType, Ident)
-> StateT DVState Identity [(PredType, Ident)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM 2 ((Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> (Type -> Type)
-> Type
-> StateT DVState Identity (PredType, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) Type
ty)
  let [v1 :: (PredType, Ident)
v1, v2 :: (PredType, Ident)
v2] = [(PredType, Ident)]
vs
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
NoSpanInfo PredType
pty Ident
enumFromThenId
    (((PredType, Ident) -> Pattern PredType)
-> [(PredType, Ident)] -> [Pattern PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo)) [(PredType, Ident)]
vs) (Expression PredType -> Decl PredType)
-> Expression PredType -> Decl PredType
forall a b. (a -> b) -> a -> b
$
    (PredType, Ident)
-> (PredType, Ident)
-> QualIdent
-> QualIdent
-> Expression PredType
enumFromThenExpr (PredType, Ident)
v1 (PredType, Ident)
v2 QualIdent
c1 QualIdent
c2

enumFromThenExpr :: (PredType, Ident) -> (PredType, Ident) -> QualIdent
                 -> QualIdent -> Expression PredType
enumFromThenExpr :: (PredType, Ident)
-> (PredType, Ident)
-> QualIdent
-> QualIdent
-> Expression PredType
enumFromThenExpr v1 :: (PredType, Ident)
v1 v2 :: (PredType, Ident)
v2 c1 :: QualIdent
c1 c2 :: QualIdent
c2 =
  Expression PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
prelEnumFromThenTo ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v1) ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v2) Expression PredType
boundedExpr
  where boundedExpr :: Expression PredType
boundedExpr = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
NoSpanInfo
                                 (Expression PredType -> Expression PredType -> Expression PredType
prelLeq
                                   (Expression PredType -> Expression PredType
prelFromEnum (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v1)
                                   (Expression PredType -> Expression PredType
prelFromEnum (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v2))
                                 (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo ((PredType, Ident) -> PredType
forall a b. (a, b) -> a
fst (PredType, Ident)
v1) QualIdent
c2)
                                 (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo ((PredType, Ident) -> PredType
forall a b. (a, b) -> a
fst (PredType, Ident)
v1) QualIdent
c1)

-- Upper and Lower Bounds:

deriveBoundedMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveBoundedMethods :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveBoundedMethods ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = [StateT DVState Identity (Decl PredType)]
-> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [ QualIdent
-> Type
-> ConstrInfo
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveMaxOrMinBound QualIdent
qMinBoundId Type
ty ([ConstrInfo] -> ConstrInfo
forall a. [a] -> a
head [ConstrInfo]
cis) PredSet
ps
  , QualIdent
-> Type
-> ConstrInfo
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveMaxOrMinBound QualIdent
qMaxBoundId Type
ty ([ConstrInfo] -> ConstrInfo
forall a. [a] -> a
last [ConstrInfo]
cis) PredSet
ps
  ]

deriveMaxOrMinBound :: QualIdent -> Type -> ConstrInfo -> PredSet
                    -> DVM (Decl PredType)
deriveMaxOrMinBound :: QualIdent
-> Type
-> ConstrInfo
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveMaxOrMinBound f :: QualIdent
f ty :: Type
ty (_, c :: QualIdent
c, _, tys :: [Type]
tys) ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qBoundedId Type
ty (Ident -> DVM PredType) -> Ident -> DVM PredType
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
unqualify QualIdent
f
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
NoSpanInfo PredType
pty (QualIdent -> Ident
unqualify QualIdent
f) [] (Expression PredType -> Decl PredType)
-> Expression PredType -> Decl PredType
forall a b. (a -> b) -> a -> b
$ QualIdent -> QualIdent -> Type -> [Type] -> Expression PredType
maxOrMinBoundExpr QualIdent
f QualIdent
c Type
ty [Type]
tys

maxOrMinBoundExpr :: QualIdent -> QualIdent -> Type -> [Type]
                  -> Expression PredType
maxOrMinBoundExpr :: QualIdent -> QualIdent -> Type -> [Type] -> Expression PredType
maxOrMinBoundExpr f :: QualIdent
f c :: QualIdent
c ty :: Type
ty tys :: [Type]
tys =
  Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
pty QualIdent
c) ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  (Type -> Expression PredType) -> [Type] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> QualIdent -> Expression PredType)
-> QualIdent -> PredType -> Expression PredType
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo) QualIdent
f (PredType -> Expression PredType)
-> (Type -> PredType) -> Type -> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> PredType
predType) [Type]
instTys
  where instTy :: Type
instTy:instTys :: [Type]
instTys = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
instType ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ Type
ty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
tys
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow Type
instTy [Type]
instTys

-- Read:

deriveReadMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveReadMethods :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveReadMethods ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = [StateT DVState Identity (Decl PredType)]
-> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveReadsPrec Type
ty [ConstrInfo]
cis PredSet
ps]

deriveReadsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveReadsPrec :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveReadsPrec ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qReadId Type
ty Ident
readsPrecId
  (PredType, Ident)
d <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument Type
intType
  (PredType, Ident)
r <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument Type
stringType
  let pats :: [Pattern PredType]
pats = ((PredType, Ident) -> Pattern PredType)
-> [(PredType, Ident)] -> [Pattern PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo)) [(PredType, Ident)
d, (PredType, Ident)
r]
  SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
NoSpanInfo PredType
pty Ident
readsPrecId [Pattern PredType]
pats (Expression PredType -> Decl PredType)
-> StateT DVState Identity (Expression PredType)
-> StateT DVState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Type
-> [ConstrInfo]
-> Expression PredType
-> Expression PredType
-> StateT DVState Identity (Expression PredType)
deriveReadsPrecExpr Type
ty [ConstrInfo]
cis ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
d) ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
r)

deriveReadsPrecExpr :: Type -> [ConstrInfo] -> Expression PredType
                    -> Expression PredType -> DVM (Expression PredType)
deriveReadsPrecExpr :: Type
-> [ConstrInfo]
-> Expression PredType
-> Expression PredType
-> StateT DVState Identity (Expression PredType)
deriveReadsPrecExpr ty :: Type
ty cis :: [ConstrInfo]
cis d :: Expression PredType
d r :: Expression PredType
r = do
  [Expression PredType]
es <- (ConstrInfo -> StateT DVState Identity (Expression PredType))
-> [ConstrInfo] -> StateT DVState Identity [Expression PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type
-> Expression PredType
-> ConstrInfo
-> StateT DVState Identity (Expression PredType)
deriveReadsPrecReadParenExpr Type
ty Expression PredType
d) [ConstrInfo]
cis
  Expression PredType
-> StateT DVState Identity (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType
 -> StateT DVState Identity (Expression PredType))
-> Expression PredType
-> StateT DVState Identity (Expression PredType)
forall a b. (a -> b) -> a -> b
$ (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Expression PredType -> Expression PredType -> Expression PredType
prelAppend ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (Expression PredType -> Expression PredType)
-> [Expression PredType] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((Expression PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo) Expression PredType
r) [Expression PredType]
es

deriveReadsPrecReadParenExpr :: Type -> Expression PredType -> ConstrInfo
                             -> DVM (Expression PredType)
deriveReadsPrecReadParenExpr :: Type
-> Expression PredType
-> ConstrInfo
-> StateT DVState Identity (Expression PredType)
deriveReadsPrecReadParenExpr ty :: Type
ty d :: Expression PredType
d ci :: ConstrInfo
ci@(_, c :: QualIdent
c, _, _) = do
  OpPrecEnv
pEnv <- DVM OpPrecEnv
getPrecEnv
  let p :: Integer
p = QualIdent -> OpPrecEnv -> Integer
precedence QualIdent
c OpPrecEnv
pEnv
  Expression PredType
e <- Type
-> ConstrInfo
-> Integer
-> StateT DVState Identity (Expression PredType)
deriveReadsPrecLambdaExpr Type
ty ConstrInfo
ci Integer
p
  Expression PredType
-> StateT DVState Identity (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType
 -> StateT DVState Identity (Expression PredType))
-> Expression PredType
-> StateT DVState Identity (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Expression PredType -> Expression PredType
prelReadParen (ConstrInfo -> Expression PredType -> Integer -> Expression PredType
readsPrecReadParenCondExpr ConstrInfo
ci Expression PredType
d Integer
p) Expression PredType
e

readsPrecReadParenCondExpr :: ConstrInfo -> Expression PredType -> Precedence
                           -> Expression PredType
readsPrecReadParenCondExpr :: ConstrInfo -> Expression PredType -> Integer -> Expression PredType
readsPrecReadParenCondExpr (_, c :: QualIdent
c, _, tys :: [Type]
tys) d :: Expression PredType
d p :: Integer
p
  | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys                        = Expression PredType
prelFalse
  | QualIdent -> Bool
isQInfixOp QualIdent
c Bool -> Bool -> Bool
&& [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 =
    Expression PredType -> Expression PredType -> Expression PredType
prelLt (SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predIntType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int Integer
p) Expression PredType
d
  | Bool
otherwise                       =
    Expression PredType -> Expression PredType -> Expression PredType
prelLt (SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predIntType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int 10) Expression PredType
d

deriveReadsPrecLambdaExpr :: Type -> ConstrInfo -> Precedence
                      -> DVM (Expression PredType)
deriveReadsPrecLambdaExpr :: Type
-> ConstrInfo
-> Integer
-> StateT DVState Identity (Expression PredType)
deriveReadsPrecLambdaExpr ty :: Type
ty (_, c :: QualIdent
c, ls :: Maybe [Ident]
ls, tys :: [Type]
tys) p :: Integer
p = do
  (PredType, Ident)
r <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument Type
stringType
  (stmts :: [Statement PredType]
stmts, vs :: [(PredType, Ident)]
vs, s :: (PredType, Ident)
s) <- Ident
-> Integer
-> (PredType, Ident)
-> Maybe [Ident]
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecStmts (QualIdent -> Ident
unqualify QualIdent
c) (Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1) (PredType, Ident)
r Maybe [Ident]
ls [Type]
tys
  let pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TypeArrow (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) (Type -> Type
instType Type
ty) [Type]
tys
      e :: Expression PredType
e = SpanInfo -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> [Expression a] -> Expression a
Tuple SpanInfo
NoSpanInfo
                [ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
pty QualIdent
c) ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ ((PredType, Ident) -> Expression PredType)
-> [(PredType, Ident)] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar) [(PredType, Ident)]
vs
                , (PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
s
                ]
  Expression PredType
-> StateT DVState Identity (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType
 -> StateT DVState Identity (Expression PredType))
-> Expression PredType
-> StateT DVState Identity (Expression PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> [Pattern PredType] -> Expression PredType -> Expression PredType
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
NoSpanInfo [(PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
r]
         (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Expression PredType
-> [Statement PredType]
-> Expression PredType
forall a. SpanInfo -> Expression a -> [Statement a] -> Expression a
ListCompr SpanInfo
NoSpanInfo Expression PredType
e [Statement PredType]
stmts

deriveReadsPrecStmts
  :: Ident -> Precedence -> (PredType, Ident) -> Maybe [Ident] -> [Type]
  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecStmts :: Ident
-> Integer
-> (PredType, Ident)
-> Maybe [Ident]
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecStmts c :: Ident
c p :: Integer
p r :: (PredType, Ident)
r ls :: Maybe [Ident]
ls tys :: [Type]
tys
  | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys                       = Ident
-> (PredType, Ident)
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecNullaryConstrStmts Ident
c (PredType, Ident)
r
  | Maybe [Ident] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Ident]
ls                      =
    Ident
-> (PredType, Ident)
-> [Ident]
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecRecordConstrStmts Ident
c (PredType, Ident)
r (Maybe [Ident] -> [Ident]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [Ident]
ls) [Type]
tys
  | Ident -> Bool
isInfixOp Ident
c Bool -> Bool -> Bool
&& [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = Ident
-> Integer
-> (PredType, Ident)
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecInfixConstrStmts Ident
c Integer
p (PredType, Ident)
r [Type]
tys
  | Bool
otherwise                      = Ident
-> (PredType, Ident)
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecConstrStmts Ident
c (PredType, Ident)
r [Type]
tys

deriveReadsPrecNullaryConstrStmts
  :: Ident -> (PredType, Ident)
  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecNullaryConstrStmts :: Ident
-> (PredType, Ident)
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecNullaryConstrStmts c :: Ident
c r :: (PredType, Ident)
r = do
  (s :: (PredType, Ident)
s, stmt :: Statement PredType
stmt) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt (Ident -> String
idName Ident
c) (PredType, Ident)
r
  ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Statement PredType
stmt], [], (PredType, Ident)
s)

deriveReadsPrecRecordConstrStmts
  :: Ident -> (PredType, Ident) -> [Ident] -> [Type]
  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecRecordConstrStmts :: Ident
-> (PredType, Ident)
-> [Ident]
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecRecordConstrStmts c :: Ident
c r :: (PredType, Ident)
r ls :: [Ident]
ls tys :: [Type]
tys = do
  (s :: (PredType, Ident)
s, stmt1 :: Statement PredType
stmt1) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt (Ident -> String
idName Ident
c) (PredType, Ident)
r
  (t :: (PredType, Ident)
t, ress :: [([Statement PredType], (PredType, Ident))]
ress) <-
    ((PredType, Ident)
 -> (String, Ident, Type)
 -> StateT
      DVState
      Identity
      ((PredType, Ident), ([Statement PredType], (PredType, Ident))))
-> (PredType, Ident)
-> [(String, Ident, Type)]
-> StateT
     DVState
     Identity
     ((PredType, Ident), [([Statement PredType], (PredType, Ident))])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (PredType, Ident)
-> (String, Ident, Type)
-> StateT
     DVState
     Identity
     ((PredType, Ident), ([Statement PredType], (PredType, Ident)))
deriveReadsPrecFieldStmts (PredType, Ident)
s ([(String, Ident, Type)]
 -> StateT
      DVState
      Identity
      ((PredType, Ident), [([Statement PredType], (PredType, Ident))]))
-> [(String, Ident, Type)]
-> StateT
     DVState
     Identity
     ((PredType, Ident), [([Statement PredType], (PredType, Ident))])
forall a b. (a -> b) -> a -> b
$ [String] -> [Ident] -> [Type] -> [(String, Ident, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ("{" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
forall a. a -> [a]
repeat ",") [Ident]
ls [Type]
tys
  let (stmtss :: [[Statement PredType]]
stmtss, vs :: [(PredType, Ident)]
vs) = [([Statement PredType], (PredType, Ident))]
-> ([[Statement PredType]], [(PredType, Ident)])
forall a b. [(a, b)] -> ([a], [b])
unzip [([Statement PredType], (PredType, Ident))]
ress
  (u :: (PredType, Ident)
u, stmt2 :: Statement PredType
stmt2) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt "}" (PredType, Ident)
t
  ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement PredType
stmt1 Statement PredType -> [Statement PredType] -> [Statement PredType]
forall a. a -> [a] -> [a]
: [[Statement PredType]] -> [Statement PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Statement PredType]]
stmtss [Statement PredType]
-> [Statement PredType] -> [Statement PredType]
forall a. [a] -> [a] -> [a]
++ [Statement PredType
stmt2], [(PredType, Ident)]
vs, (PredType, Ident)
u)

deriveReadsPrecFieldStmts
  :: (PredType, Ident) -> (String, Ident, Type)
  -> DVM ((PredType, Ident), ([Statement PredType], (PredType, Ident)))
deriveReadsPrecFieldStmts :: (PredType, Ident)
-> (String, Ident, Type)
-> StateT
     DVState
     Identity
     ((PredType, Ident), ([Statement PredType], (PredType, Ident)))
deriveReadsPrecFieldStmts r :: (PredType, Ident)
r (pre :: String
pre, l :: Ident
l, ty :: Type
ty) = do
  (s :: (PredType, Ident)
s, stmt1 :: Statement PredType
stmt1) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt String
pre (PredType, Ident)
r
  (t :: (PredType, Ident)
t, stmt2 :: Statement PredType
stmt2) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt (Ident -> String
idName Ident
l) (PredType, Ident)
s
  (u :: (PredType, Ident)
u, stmt3 :: Statement PredType
stmt3) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt "=" (PredType, Ident)
t
  (w :: (PredType, Ident)
w, (stmt4 :: Statement PredType
stmt4, v :: (PredType, Ident)
v)) <- Integer
-> (PredType, Ident)
-> Type
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
deriveReadsPrecReadsPrecStmt 0 (PredType, Ident)
u Type
ty
  ((PredType, Ident), ([Statement PredType], (PredType, Ident)))
-> StateT
     DVState
     Identity
     ((PredType, Ident), ([Statement PredType], (PredType, Ident)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredType, Ident)
w, ([Statement PredType
stmt1, Statement PredType
stmt2, Statement PredType
stmt3, Statement PredType
stmt4], (PredType, Ident)
v))

deriveReadsPrecInfixConstrStmts
  :: Ident -> Precedence -> (PredType, Ident) -> [Type]
  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecInfixConstrStmts :: Ident
-> Integer
-> (PredType, Ident)
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecInfixConstrStmts c :: Ident
c p :: Integer
p r :: (PredType, Ident)
r tys :: [Type]
tys = do
  (s :: (PredType, Ident)
s, (stmt1 :: Statement PredType
stmt1, v1 :: (PredType, Ident)
v1)) <- Integer
-> (PredType, Ident)
-> Type
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
deriveReadsPrecReadsPrecStmt (Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1) (PredType, Ident)
r (Type
 -> DVM
      ((PredType, Ident), (Statement PredType, (PredType, Ident))))
-> Type
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
forall a. [a] -> a
head [Type]
tys
  (t :: (PredType, Ident)
t, stmt2 :: Statement PredType
stmt2) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt (Ident -> String
idName Ident
c) (PredType, Ident)
s
  (u :: (PredType, Ident)
u, (stmt3 :: Statement PredType
stmt3, v2 :: (PredType, Ident)
v2)) <- Integer
-> (PredType, Ident)
-> Type
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
deriveReadsPrecReadsPrecStmt (Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1) (PredType, Ident)
t (Type
 -> DVM
      ((PredType, Ident), (Statement PredType, (PredType, Ident))))
-> Type
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
forall a. [a] -> a
head ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> [Type]
forall a. [a] -> [a]
tail [Type]
tys
  ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Statement PredType
stmt1, Statement PredType
stmt2, Statement PredType
stmt3], [(PredType, Ident)
v1, (PredType, Ident)
v2], (PredType, Ident)
u)

deriveReadsPrecConstrStmts
  :: Ident -> (PredType, Ident) -> [Type]
  -> DVM ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecConstrStmts :: Ident
-> (PredType, Ident)
-> [Type]
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
deriveReadsPrecConstrStmts c :: Ident
c r :: (PredType, Ident)
r tys :: [Type]
tys = do
    (s :: (PredType, Ident)
s, stmt :: Statement PredType
stmt) <- String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt (Ident -> String
idName Ident
c) (PredType, Ident)
r
    (t :: (PredType, Ident)
t, ress :: [(Statement PredType, (PredType, Ident))]
ress) <- ((PredType, Ident)
 -> Type
 -> DVM
      ((PredType, Ident), (Statement PredType, (PredType, Ident))))
-> (PredType, Ident)
-> [Type]
-> StateT
     DVState
     Identity
     ((PredType, Ident), [(Statement PredType, (PredType, Ident))])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (Integer
-> (PredType, Ident)
-> Type
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
deriveReadsPrecReadsPrecStmt 11) (PredType, Ident)
s [Type]
tys
    let (stmts :: [Statement PredType]
stmts, vs :: [(PredType, Ident)]
vs) = [(Statement PredType, (PredType, Ident))]
-> ([Statement PredType], [(PredType, Ident)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Statement PredType, (PredType, Ident))]
ress
    ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
-> DVM
     ([Statement PredType], [(PredType, Ident)], (PredType, Ident))
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement PredType
stmt Statement PredType -> [Statement PredType] -> [Statement PredType]
forall a. a -> [a] -> [a]
: [Statement PredType]
stmts, [(PredType, Ident)]
vs, (PredType, Ident)
t)

deriveReadsPrecLexStmt :: String -> (PredType, Ident)
                      -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt :: String
-> (PredType, Ident) -> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt str :: String
str r :: (PredType, Ident)
r = do
  (PredType, Ident)
s <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument Type
stringType
  let pat :: Pattern PredType
pat  = SpanInfo -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
NoSpanInfo
               [ SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo PredType
predStringType (Literal -> Pattern PredType) -> Literal -> Pattern PredType
forall a b. (a -> b) -> a -> b
$ String -> Literal
String String
str
               , (PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
s
               ]
      stmt :: Statement PredType
stmt = SpanInfo
-> Pattern PredType -> Expression PredType -> Statement PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Statement a
StmtBind SpanInfo
NoSpanInfo Pattern PredType
pat (Expression PredType -> Statement PredType)
-> Expression PredType -> Statement PredType
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Expression PredType
preludeLex (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
r
  ((PredType, Ident), Statement PredType)
-> DVM ((PredType, Ident), Statement PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredType, Ident)
s, Statement PredType
stmt)

deriveReadsPrecReadsPrecStmt  :: Precedence -> (PredType, Ident) -> Type
      -> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
deriveReadsPrecReadsPrecStmt :: Integer
-> (PredType, Ident)
-> Type
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
deriveReadsPrecReadsPrecStmt p :: Integer
p r :: (PredType, Ident)
r ty :: Type
ty = do
  (PredType, Ident)
v <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> Type -> StateT DVState Identity (PredType, Ident)
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty
  (PredType, Ident)
s <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> Type -> StateT DVState Identity (PredType, Ident)
forall a b. (a -> b) -> a -> b
$ Type
stringType
  let pat :: Pattern PredType
pat  = SpanInfo -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
NoSpanInfo ([Pattern PredType] -> Pattern PredType)
-> [Pattern PredType] -> Pattern PredType
forall a b. (a -> b) -> a -> b
$
               ((PredType, Ident) -> Pattern PredType)
-> [(PredType, Ident)] -> [Pattern PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo)) [(PredType, Ident)
v, (PredType, Ident)
s]
      stmt :: Statement PredType
stmt = SpanInfo
-> Pattern PredType -> Expression PredType -> Statement PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Statement a
StmtBind SpanInfo
NoSpanInfo Pattern PredType
pat (Expression PredType -> Statement PredType)
-> Expression PredType -> Statement PredType
forall a b. (a -> b) -> a -> b
$ Type -> Integer -> Expression PredType -> Expression PredType
preludeReadsPrec (Type -> Type
instType Type
ty) Integer
p (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
               (PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
r
  ((PredType, Ident), (Statement PredType, (PredType, Ident)))
-> DVM ((PredType, Ident), (Statement PredType, (PredType, Ident)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredType, Ident)
s, (Statement PredType
stmt, (PredType, Ident)
v))

-- Show:

deriveShowMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveShowMethods :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity [Decl PredType]
deriveShowMethods ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = [StateT DVState Identity (Decl PredType)]
-> StateT DVState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveShowsPrec Type
ty [ConstrInfo]
cis PredSet
ps]

deriveShowsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveShowsPrec :: Type
-> [ConstrInfo]
-> PredSet
-> StateT DVState Identity (Decl PredType)
deriveShowsPrec ty :: Type
ty cis :: [ConstrInfo]
cis ps :: PredSet
ps = do
  PredType
pty <- PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType PredSet
ps QualIdent
qShowId Type
ty Ident
showsPrecId
  [Equation PredType]
eqs <- (ConstrInfo -> StateT DVState Identity (Equation PredType))
-> [ConstrInfo] -> StateT DVState Identity [Equation PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> ConstrInfo -> StateT DVState Identity (Equation PredType)
deriveShowsPrecEquation Type
ty) [ConstrInfo]
cis
  Decl PredType -> StateT DVState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DVState Identity (Decl PredType))
-> Decl PredType -> StateT DVState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
NoSpanInfo PredType
pty Ident
showsPrecId [Equation PredType]
eqs

deriveShowsPrecEquation :: Type -> ConstrInfo -> DVM (Equation PredType)
deriveShowsPrecEquation :: Type -> ConstrInfo -> StateT DVState Identity (Equation PredType)
deriveShowsPrecEquation ty :: Type
ty (_, c :: QualIdent
c, ls :: Maybe [Ident]
ls, tys :: [Type]
tys) = do
  (PredType, Ident)
d <- Type -> StateT DVState Identity (PredType, Ident)
freshArgument Type
intType
  [(PredType, Ident)]
vs <- (Type -> StateT DVState Identity (PredType, Ident))
-> [Type] -> StateT DVState Identity [(PredType, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> StateT DVState Identity (PredType, Ident)
freshArgument (Type -> StateT DVState Identity (PredType, Ident))
-> (Type -> Type)
-> Type
-> StateT DVState Identity (PredType, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) [Type]
tys
  let pats :: [Pattern PredType]
pats = [(PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
d, PredType -> QualIdent -> [(PredType, Ident)] -> Pattern PredType
forall a. a -> QualIdent -> [(a, Ident)] -> Pattern a
constrPattern PredType
pty QualIdent
c [(PredType, Ident)]
vs]
  OpPrecEnv
pEnv <- DVM OpPrecEnv
getPrecEnv
  Equation PredType -> StateT DVState Identity (Equation PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Equation PredType -> StateT DVState Identity (Equation PredType))
-> Equation PredType -> StateT DVState Identity (Equation PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
showsPrecId [Pattern PredType]
pats (Expression PredType -> Equation PredType)
-> Expression PredType -> Equation PredType
forall a b. (a -> b) -> a -> b
$ Ident
-> Integer
-> Maybe [Ident]
-> Expression PredType
-> [Expression PredType]
-> Expression PredType
showsPrecExpr (QualIdent -> Ident
unqualify QualIdent
c)
    (QualIdent -> OpPrecEnv -> Integer
precedence QualIdent
c OpPrecEnv
pEnv) Maybe [Ident]
ls ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
d) ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ ((PredType, Ident) -> Expression PredType)
-> [(PredType, Ident)] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar) [(PredType, Ident)]
vs
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty

showsPrecExpr :: Ident -> Precedence -> Maybe [Ident] -> Expression PredType
              -> [Expression PredType] -> Expression PredType
showsPrecExpr :: Ident
-> Integer
-> Maybe [Ident]
-> Expression PredType
-> [Expression PredType]
-> Expression PredType
showsPrecExpr c :: Ident
c p :: Integer
p ls :: Maybe [Ident]
ls d :: Expression PredType
d vs :: [Expression PredType]
vs
  | [Expression PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression PredType]
vs                       = Ident -> Expression PredType
showsPrecNullaryConstrExpr Ident
c
  | Maybe [Ident] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Ident]
ls                     = Expression PredType
-> Integer -> Expression PredType -> Expression PredType
showsPrecShowParenExpr Expression PredType
d 10 (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
    Ident -> [Ident] -> [Expression PredType] -> Expression PredType
showsPrecRecordConstrExpr Ident
c (Maybe [Ident] -> [Ident]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [Ident]
ls) [Expression PredType]
vs
  | Ident -> Bool
isInfixOp Ident
c Bool -> Bool -> Bool
&& [Expression PredType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression PredType]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = Expression PredType
-> Integer -> Expression PredType -> Expression PredType
showsPrecShowParenExpr Expression PredType
d Integer
p (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
    Ident -> Integer -> [Expression PredType] -> Expression PredType
showsPrecInfixConstrExpr Ident
c Integer
p [Expression PredType]
vs
  | Bool
otherwise                     = Expression PredType
-> Integer -> Expression PredType -> Expression PredType
showsPrecShowParenExpr Expression PredType
d 10 (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
    Ident -> [Expression PredType] -> Expression PredType
showsPrecConstrExpr Ident
c [Expression PredType]
vs

showsPrecNullaryConstrExpr :: Ident -> Expression PredType
showsPrecNullaryConstrExpr :: Ident -> Expression PredType
showsPrecNullaryConstrExpr c :: Ident
c = String -> Expression PredType
preludeShowString (String -> Expression PredType) -> String -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Ident -> String -> String
showsConstr Ident
c ""

showsPrecShowParenExpr :: Expression PredType -> Precedence
                       -> Expression PredType -> Expression PredType
showsPrecShowParenExpr :: Expression PredType
-> Integer -> Expression PredType -> Expression PredType
showsPrecShowParenExpr d :: Expression PredType
d p :: Integer
p =
  Expression PredType -> Expression PredType -> Expression PredType
prelShowParen (Expression PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Expression PredType -> Expression PredType
prelLt (SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predIntType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int Integer
p) Expression PredType
d

showsPrecRecordConstrExpr :: Ident -> [Ident] -> [Expression PredType]
                          -> Expression PredType
showsPrecRecordConstrExpr :: Ident -> [Ident] -> [Expression PredType] -> Expression PredType
showsPrecRecordConstrExpr c :: Ident
c ls :: [Ident]
ls vs :: [Expression PredType]
vs = (Expression PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> [Expression PredType]
-> Expression PredType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Expression PredType -> Expression PredType -> Expression PredType
prelDot (String -> Expression PredType
preludeShowString "}") ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  (:) (String -> Expression PredType
preludeShowString (String -> Expression PredType) -> String -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Ident -> String -> String
showsConstr Ident
c " {") ([Expression PredType] -> [Expression PredType])
-> [Expression PredType] -> [Expression PredType]
forall a b. (a -> b) -> a -> b
$
    [Expression PredType]
-> [[Expression PredType]] -> [Expression PredType]
forall a. [a] -> [[a]] -> [a]
intercalate [String -> Expression PredType
preludeShowString ", "] ([[Expression PredType]] -> [Expression PredType])
-> [[Expression PredType]] -> [Expression PredType]
forall a b. (a -> b) -> a -> b
$ (Ident -> Expression PredType -> [Expression PredType])
-> [Ident] -> [Expression PredType] -> [[Expression PredType]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Ident -> Expression PredType -> [Expression PredType]
showsPrecFieldExpr [Ident]
ls [Expression PredType]
vs

showsPrecFieldExpr :: Ident -> Expression PredType -> [Expression PredType]
showsPrecFieldExpr :: Ident -> Expression PredType -> [Expression PredType]
showsPrecFieldExpr l :: Ident
l v :: Expression PredType
v =
  [String -> Expression PredType
preludeShowString (String -> Expression PredType) -> String -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Ident -> String -> String
showsConstr Ident
l " = ", Integer -> Expression PredType -> Expression PredType
preludeShowsPrec 0 Expression PredType
v]

showsPrecInfixConstrExpr :: Ident -> Precedence -> [Expression PredType]
                         -> Expression PredType
showsPrecInfixConstrExpr :: Ident -> Integer -> [Expression PredType] -> Expression PredType
showsPrecInfixConstrExpr c :: Ident
c p :: Integer
p vs :: [Expression PredType]
vs = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Expression PredType -> Expression PredType -> Expression PredType
prelDot
  [ Integer -> Expression PredType -> Expression PredType
preludeShowsPrec (Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$ [Expression PredType] -> Expression PredType
forall a. [a] -> a
head [Expression PredType]
vs
  , String -> Expression PredType
preludeShowString (String -> Expression PredType) -> String -> Expression PredType
forall a b. (a -> b) -> a -> b
$ ' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Ident -> String
idName Ident
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "
  , Integer -> Expression PredType -> Expression PredType
preludeShowsPrec (Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$ [Expression PredType] -> Expression PredType
forall a. [a] -> a
head ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ [Expression PredType] -> [Expression PredType]
forall a. [a] -> [a]
tail [Expression PredType]
vs
  ]

showsPrecConstrExpr :: Ident -> [Expression PredType] -> Expression PredType
showsPrecConstrExpr :: Ident -> [Expression PredType] -> Expression PredType
showsPrecConstrExpr c :: Ident
c vs :: [Expression PredType]
vs = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Expression PredType -> Expression PredType -> Expression PredType
prelDot ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  String -> Expression PredType
preludeShowString (Ident -> String -> String
showsConstr Ident
c " ") Expression PredType
-> [Expression PredType] -> [Expression PredType]
forall a. a -> [a] -> [a]
:
    Expression PredType
-> [Expression PredType] -> [Expression PredType]
forall a. a -> [a] -> [a]
intersperse (String -> Expression PredType
preludeShowString " ") ((Expression PredType -> Expression PredType)
-> [Expression PredType] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Expression PredType -> Expression PredType
preludeShowsPrec 11) [Expression PredType]
vs)

-- -----------------------------------------------------------------------------
-- Generating variables
-- -----------------------------------------------------------------------------

freshArgument :: Type -> DVM (PredType, Ident)
freshArgument :: Type -> StateT DVState Identity (PredType, Ident)
freshArgument = String -> Type -> StateT DVState Identity (PredType, Ident)
freshVar "_#arg"

freshVar :: String -> Type -> DVM (PredType, Ident)
freshVar :: String -> Type -> StateT DVState Identity (PredType, Ident)
freshVar name :: String
name ty :: Type
ty =
  ((,) (Type -> PredType
predType Type
ty)) (Ident -> (PredType, Ident))
-> (Integer -> Ident) -> Integer -> (PredType, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
mkIdent (String -> Ident) -> (Integer -> String) -> Integer -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Integer -> String) -> Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Integer -> String
forall a. Show a => a -> String
show (Integer -> (PredType, Ident))
-> DVM Integer -> StateT DVState Identity (PredType, Ident)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DVM Integer
getNextId

-- -----------------------------------------------------------------------------
-- Auxiliary functions
-- -----------------------------------------------------------------------------

constructors :: ModuleIdent -> QualIdent -> TCEnv -> [ConstrInfo]
constructors :: ModuleIdent -> QualIdent -> TCEnv -> [ConstrInfo]
constructors m :: ModuleIdent
m tc :: QualIdent
tc tcEnv :: TCEnv
tcEnv =  (Int -> DataConstr -> ConstrInfo)
-> [Int] -> [DataConstr] -> [ConstrInfo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ModuleIdent -> Int -> DataConstr -> ConstrInfo
mkConstrInfo ModuleIdent
m) [1 ..] ([DataConstr] -> [ConstrInfo]) -> [DataConstr] -> [ConstrInfo]
forall a b. (a -> b) -> a -> b
$
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
tc TCEnv
tcEnv of
    [DataType     _ _ cs :: [DataConstr]
cs] -> [DataConstr]
cs
    [RenamingType _ _ nc :: DataConstr
nc] -> [DataConstr
nc]
    _                     -> String -> [DataConstr]
forall a. String -> a
internalError (String -> [DataConstr]) -> String -> [DataConstr]
forall a b. (a -> b) -> a -> b
$ "Derive.constructors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
tc

mkConstrInfo :: ModuleIdent -> Int -> DataConstr -> ConstrInfo
mkConstrInfo :: ModuleIdent -> Int -> DataConstr -> ConstrInfo
mkConstrInfo m :: ModuleIdent
m i :: Int
i (DataConstr   c :: Ident
c    tys :: [Type]
tys) =
  (Int
i, ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
c, Maybe [Ident]
forall a. Maybe a
Nothing, [Type]
tys)
mkConstrInfo m :: ModuleIdent
m i :: Int
i (RecordConstr c :: Ident
c ls :: [Ident]
ls tys :: [Type]
tys) =
  (Int
i, ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
c, [Ident] -> Maybe [Ident]
forall a. a -> Maybe a
Just [Ident]
ls, [Type]
tys)

showsConstr :: Ident -> ShowS
showsConstr :: Ident -> String -> String
showsConstr c :: Ident
c = Bool -> (String -> String) -> String -> String
showParen (Ident -> Bool
isInfixOp Ident
c) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
showString (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ Ident -> String
idName Ident
c

precedence :: QualIdent -> OpPrecEnv -> Precedence
precedence :: QualIdent -> OpPrecEnv -> Integer
precedence op :: QualIdent
op pEnv :: OpPrecEnv
pEnv = case QualIdent -> OpPrecEnv -> [PrecInfo]
qualLookupP QualIdent
op OpPrecEnv
pEnv of
  [] -> Integer
defaultPrecedence
  PrecInfo _ (OpPrec _ p :: Integer
p) : _ -> Integer
p

instType :: Type -> Type
instType :: Type -> Type
instType (TypeConstructor tc :: QualIdent
tc) = QualIdent -> Type
TypeConstructor QualIdent
tc
instType (TypeVariable    tv :: Int
tv) = Int -> Type
TypeVariable (-1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tv)
instType (TypeApply  ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Type -> Type
TypeApply (Type -> Type
instType Type
ty1) (Type -> Type
instType Type
ty2)
instType (TypeArrow  ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Type -> Type
TypeArrow (Type -> Type
instType Type
ty1) (Type -> Type
instType Type
ty2)
instType ty :: Type
ty = Type
ty

-- Returns the type for a given instance's method of a given class. To this
-- end, the class method's type is stripped of its first predicate (which is
-- the implicit class constraint) and the class variable is replaced with the
-- instance's type. The remaining predicate set is then united with the
-- instance's predicate set.

getInstMethodType :: PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType :: PredSet -> QualIdent -> Type -> Ident -> DVM PredType
getInstMethodType ps :: PredSet
ps cls :: QualIdent
cls ty :: Type
ty f :: Ident
f = do
  ValueEnv
vEnv <- DVM ValueEnv
getValueEnv
  PredType -> DVM PredType
forall (m :: * -> *) a. Monad m => a -> m a
return (PredType -> DVM PredType) -> PredType -> DVM PredType
forall a b. (a -> b) -> a -> b
$ ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType ValueEnv
vEnv PredSet
ps QualIdent
cls Type
ty Ident
f

instMethodType :: ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType :: ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType vEnv :: ValueEnv
vEnv ps :: PredSet
ps cls :: QualIdent
cls ty :: Type
ty f :: Ident
f = PredSet -> Type -> PredType
PredType (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps'') Type
ty''
  where PredType ps' :: PredSet
ps' ty' :: Type
ty' = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls Ident
f) ValueEnv
vEnv of
          [Value _ _ _ (ForAll _ pty :: PredType
pty)] -> PredType
pty
          _ -> String -> PredType
forall a. String -> a
internalError "Derive.instMethodType"
        PredType ps'' :: PredSet
ps'' ty'' :: Type
ty'' = Type -> PredType -> PredType
forall a. ExpandAliasType a => Type -> a -> a
instanceType Type
ty (PredType -> PredType) -> PredType -> PredType
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType (PredSet -> PredSet
forall a. Set a -> Set a
Set.deleteMin PredSet
ps') Type
ty'

-- -----------------------------------------------------------------------------
-- Prelude entities
-- -----------------------------------------------------------------------------

prelTrue :: Expression PredType
prelTrue :: Expression PredType
prelTrue = SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
predBoolType QualIdent
qTrueId

prelFalse :: Expression PredType
prelFalse :: Expression PredType
prelFalse = SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
predBoolType QualIdent
qFalseId

prelAppend :: Expression PredType -> Expression PredType -> Expression PredType
prelAppend :: Expression PredType -> Expression PredType -> Expression PredType
prelAppend e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qAppendOpId, Expression PredType
e1, Expression PredType
e2]
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate 3 (Type -> [Type]) -> Type -> [Type]
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1

prelDot :: Expression PredType -> Expression PredType -> Expression PredType
prelDot :: Expression PredType -> Expression PredType -> Expression PredType
prelDot e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qDotOpId, Expression PredType
e1, Expression PredType
e2]
  where ty1 :: Type
ty1@(TypeArrow _    ty12 :: Type
ty12) = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1
        ty2 :: Type
ty2@(TypeArrow ty21 :: Type
ty21 _   ) = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e2
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
ty1, Type
ty2, Type
ty21, Type
ty12]

prelAnd :: Expression PredType -> Expression PredType -> Expression PredType
prelAnd :: Expression PredType -> Expression PredType -> Expression PredType
prelAnd e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qAndOpId, Expression PredType
e1, Expression PredType
e2]
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate 3 Type
boolType

prelEq :: Expression PredType -> Expression PredType -> Expression PredType
prelEq :: Expression PredType -> Expression PredType -> Expression PredType
prelEq e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qEqOpId, Expression PredType
e1, Expression PredType
e2]
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
ty, Type
ty, Type
boolType]

prelDataEq :: Expression PredType -> Expression PredType -> Expression PredType
prelDataEq :: Expression PredType -> Expression PredType -> Expression PredType
prelDataEq e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qDataEqId, Expression PredType
e1, Expression PredType
e2]
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
ty, Type
ty, Type
boolType]

prelLeq :: Expression PredType -> Expression PredType -> Expression PredType
prelLeq :: Expression PredType -> Expression PredType -> Expression PredType
prelLeq e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qLeqOpId, Expression PredType
e1, Expression PredType
e2]
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
ty, Type
ty, Type
boolType]

prelLt :: Expression PredType -> Expression PredType -> Expression PredType
prelLt :: Expression PredType -> Expression PredType -> Expression PredType
prelLt e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qLtOpId, Expression PredType
e1, Expression PredType
e2]
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
ty, Type
ty, Type
boolType]

prelOr :: Expression PredType -> Expression PredType -> Expression PredType
prelOr :: Expression PredType -> Expression PredType -> Expression PredType
prelOr e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
  [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qOrOpId, Expression PredType
e1, Expression PredType
e2]
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate 3 Type
boolType

prelFromEnum :: Expression PredType -> Expression PredType
prelFromEnum :: Expression PredType -> Expression PredType
prelFromEnum e :: Expression PredType
e = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qFromEnumId) Expression PredType
e
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TypeArrow (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e) Type
intType

prelEnumFromTo :: Expression PredType -> Expression PredType
               -> Expression PredType
prelEnumFromTo :: Expression PredType -> Expression PredType -> Expression PredType
prelEnumFromTo e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qEnumFromToId) [Expression PredType
e1, Expression PredType
e2]
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
ty, Type
ty, Type -> Type
listType Type
ty]

prelEnumFromThenTo :: Expression PredType -> Expression PredType
                   -> Expression PredType -> Expression PredType
prelEnumFromThenTo :: Expression PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
prelEnumFromThenTo e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 e3 :: Expression PredType
e3 =
  Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qEnumFromThenToId) [Expression PredType
e1, Expression PredType
e2, Expression PredType
e3]
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
ty, Type
ty, Type
ty, Type -> Type
listType Type
ty]

prelReadParen :: Expression PredType -> Expression PredType
              -> Expression PredType
prelReadParen :: Expression PredType -> Expression PredType -> Expression PredType
prelReadParen e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qReadParenId) [Expression PredType
e1, Expression PredType
e2]
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e2
        pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type
boolType, Type
ty, Type
ty]

prelShowParen :: Expression PredType -> Expression PredType
              -> Expression PredType
prelShowParen :: Expression PredType -> Expression PredType -> Expression PredType
prelShowParen e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qShowParenId) [Expression PredType
e1, Expression PredType
e2]
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [ Type
boolType
                                          , Type -> Type -> Type
TypeArrow Type
stringType Type
stringType
                                          , Type
stringType, Type
stringType
                                          ]

preludeLex :: Expression PredType -> Expression PredType
preludeLex :: Expression PredType -> Expression PredType
preludeLex = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qLexId)
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TypeArrow Type
stringType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                Type -> Type
listType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
tupleType [Type
stringType, Type
stringType]

preludeReadsPrec :: Type -> Integer -> Expression PredType
                 -> Expression PredType
preludeReadsPrec :: Type -> Integer -> Expression PredType -> Expression PredType
preludeReadsPrec ty :: Type
ty p :: Integer
p e :: Expression PredType
e = (Expression PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo) Expression PredType
e (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qReadsPrecId) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predIntType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int Integer
p
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [ Type
intType, Type
stringType
                                          , Type -> Type
listType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
tupleType [ Type
ty
                                                                 , Type
stringType
                                                                 ]
                                          ]

preludeShowsPrec :: Integer -> Expression PredType -> Expression PredType
preludeShowsPrec :: Integer -> Expression PredType -> Expression PredType
preludeShowsPrec p :: Integer
p e :: Expression PredType
e = (Expression PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo) Expression PredType
e (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qShowsPrecId) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predIntType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int Integer
p
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [ Type
intType, Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e
                                          , Type
stringType, Type
stringType
                                          ]

preludeShowString :: String -> Expression PredType
preludeShowString :: String -> Expression PredType
preludeShowString s :: String
s = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty QualIdent
qShowStringId) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predStringType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ String -> Literal
String String
s
  where pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate 3 Type
stringType

preludeFailed :: Type -> Expression PredType
preludeFailed :: Type -> Expression PredType
preludeFailed ty :: Type
ty = SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo (Type -> PredType
predType Type
ty) QualIdent
qFailedId