-- 
-- (C) Susumu Katayama
--
module MagicHaskeller.Analytical.Parser where

import Data.List(sort, group, genericLength)
import Control.Monad -- hiding (guard)
import Control.Monad.State -- hiding (guard)
import Data.Char(ord)
import Data.Array
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Language.Haskell.TH hiding (match)
import Data.Maybe(fromJust)

import MagicHaskeller.CoreLang(VarLib, Var)
import qualified MagicHaskeller.Types as T
import MagicHaskeller.PriorSubsts hiding (unify)
import MagicHaskeller.TyConLib
import MagicHaskeller.ReadTHType(thTypeToType)
import qualified MagicHaskeller.PolyDynamic as PD

import MagicHaskeller.Analytical.Syntax

import Data.Word

#if __GLASGOW_HASKELL__ >= 810
unJust :: Maybe a -> a
unJust = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust
#else
unJust = id
#endif

data XVarLib = XVL {XVarLib -> VarLib
varLib :: VarLib, XVarLib -> Map String Var
invVarLib :: Map.Map String Var, XVarLib -> Var
zeroID :: Var, XVarLib -> Var
succID :: Var, XVarLib -> Var
negateID :: Var} deriving Int -> XVarLib -> ShowS
[XVarLib] -> ShowS
XVarLib -> String
(Int -> XVarLib -> ShowS)
-> (XVarLib -> String) -> ([XVarLib] -> ShowS) -> Show XVarLib
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XVarLib] -> ShowS
$cshowList :: [XVarLib] -> ShowS
show :: XVarLib -> String
$cshow :: XVarLib -> String
showsPrec :: Int -> XVarLib -> ShowS
$cshowsPrec :: Int -> XVarLib -> ShowS
Show

-- We compare nameBase ignoring the module name, instead of using equivalence over Name's.
mkXVarLib :: VarLib -> XVarLib
mkXVarLib :: VarLib -> XVarLib
mkXVarLib VarLib
vl = let
                   (Var
_,Var
mx) = VarLib -> (Var, Var)
forall i e. Array i e -> (i, i)
bounds VarLib
vl
               in XVL :: VarLib -> Map String Var -> Var -> Var -> Var -> XVarLib
XVL {varLib :: VarLib
varLib = VarLib
vl
                      , invVarLib :: Map String Var
invVarLib = (Var -> Var -> Var) -> [(String, Var)] -> Map String Var
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\Var
_ Var
a -> Var
a) ([ (Name -> String
nameBase Name
name, Var
num) | (Var
num, PD.Dynamic{dynExp :: Dynamic -> Exp
PD.dynExp=Exp
thexpr}) <- VarLib -> [(Var, Dynamic)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs VarLib
vl, Name
name <- Exp -> [Name]
extractName Exp
thexpr ])
                      , zeroID :: Var
zeroID = Var
mxVar -> Var -> Var
forall a. Num a => a -> a -> a
-Var
2   -- These are dependent on the order in CoreLang.defaultPrimitives
                      , succID :: Var
succID = Var
mxVar -> Var -> Var
forall a. Num a => a -> a -> a
-Var
1
                      , negateID :: Var
negateID = Var
mx
                      }
extractName :: Exp -> [Name]
extractName (ConE Name
name) = [Name
name]
extractName (VarE Name
name) = [Name
name]
extractName Exp
_           = []
parseTypedIOPairss :: (Functor m, MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])]
parseTypedIOPairss :: TyConLib
-> XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
parseTypedIOPairss TyConLib
tcl XVarLib
xvl [Dec]
ds = [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
inferTypedIOPairss ([(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
 -> PriorSubsts m [(Name, Typed [IOPair Type])])
-> PriorSubsts
     m [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TyConLib
-> XVarLib
-> [Dec]
-> PriorSubsts
     m [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
TyConLib
-> XVarLib
-> [Dec]
-> PriorSubsts
     m [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
parseTypedIOPairss' TyConLib
tcl XVarLib
xvl [Dec]
ds
inferTypedIOPairss :: (Functor m, MonadPlus m) => [(Name,(Maybe T.Type, Maybe (T.Typed [IOPair T.Type])))] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])]
inferTypedIOPairss :: [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
inferTypedIOPairss ((Name
name, (Just Type
ty, Just ([IOPair Type]
iops T.::: Type
infty))):[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
ts)
    = do Type
apinfty <- Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
infty
         Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
apinfty (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
T.quantify Type
ty
--         updateSubstPS (return . unquantifySubst)

         Subst
s <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
         let hd :: (Name, Typed [IOPair Type])
hd = (Name
name, (IOPair Type -> IOPair Type) -> [IOPair Type] -> [IOPair Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> IOPair Type -> IOPair Type
tapplyIOP Subst
s) [IOPair Type]
iops [IOPair Type] -> Type -> Typed [IOPair Type]
forall a. a -> Type -> Typed a
T.:::Type
ty)
         [(Name, Typed [IOPair Type])]
tl <- [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
inferTypedIOPairss [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
ts
         [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, Typed [IOPair Type])
hd(Name, Typed [IOPair Type])
-> [(Name, Typed [IOPair Type])] -> [(Name, Typed [IOPair Type])]
forall a. a -> [a] -> [a]
:[(Name, Typed [IOPair Type])]
tl)
inferTypedIOPairss ((Name
name, (Maybe Type
Nothing, Just ([IOPair Type]
iops T.::: Type
infty))):[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
ts)
    = do Subst
s <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
         let hd :: (Name, Typed [IOPair Type])
hd = (Name
name, (IOPair Type -> IOPair Type) -> [IOPair Type] -> [IOPair Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> IOPair Type -> IOPair Type
tapplyIOP Subst
s) [IOPair Type]
iops [IOPair Type] -> Type -> Typed [IOPair Type]
forall a. a -> Type -> Typed a
T.::: Subst -> Type -> Type
T.apply Subst
s Type
infty)
         [(Name, Typed [IOPair Type])]
tl <- [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
inferTypedIOPairss [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
ts
         [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, Typed [IOPair Type])
hd(Name, Typed [IOPair Type])
-> [(Name, Typed [IOPair Type])] -> [(Name, Typed [IOPair Type])]
forall a. a -> [a] -> [a]
:[(Name, Typed [IOPair Type])]
tl)
inferTypedIOPairss ((Name
_nam, (Just Type
_t, Maybe (Typed [IOPair Type])
Nothing)):[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
ts) = [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
inferTypedIOPairss [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
ts -- pattern including only a type signature. This is still useful when incorporating with MagicHaskeller, but MagH has its own parser, so let's ignore the pattern silently.
inferTypedIOPairss ((Name
_,    (Maybe Type
Nothing, Maybe (Typed [IOPair Type])
Nothing)):[(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
_)  = String -> PriorSubsts m [(Name, Typed [IOPair Type])]
forall a. HasCallStack => String -> a
error String
"MagicHaskeller.TypedIOPairs.inferTypedIOPairss: impossible"
inferTypedIOPairss [] = [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *) a. Monad m => a -> m a
return []

parseTypedIOPairss' :: (Functor m,MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, (Maybe T.Type, Maybe (T.Typed [IOPair T.Type])))]
parseTypedIOPairss' :: TyConLib
-> XVarLib
-> [Dec]
-> PriorSubsts
     m [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
parseTypedIOPairss' TyConLib
tcl XVarLib
xvl [Dec]
ds
    = do [(Name, Typed [IOPair Type])]
tups <- XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
parseIOPairss XVarLib
xvl [Dec]
ds
         [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts
     m [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
 -> PriorSubsts
      m [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))])
-> [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> PriorSubsts
     m [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
forall a b. (a -> b) -> a -> b
$ Map Name (Maybe Type, Maybe (Typed [IOPair Type]))
-> [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Name (Maybe Type, Maybe (Typed [IOPair Type]))
 -> [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))])
-> Map Name (Maybe Type, Maybe (Typed [IOPair Type]))
-> [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
forall a b. (a -> b) -> a -> b
$ ((Maybe Type, Maybe (Typed [IOPair Type]))
 -> (Maybe Type, Maybe (Typed [IOPair Type]))
 -> (Maybe Type, Maybe (Typed [IOPair Type])))
-> [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> Map Name (Maybe Type, Maybe (Typed [IOPair Type]))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (Maybe Type, Maybe (Typed [IOPair Type]))
-> (Maybe Type, Maybe (Typed [IOPair Type]))
-> (Maybe Type, Maybe (Typed [IOPair Type]))
forall (m :: * -> *) (m :: * -> *) a a.
(MonadPlus m, MonadPlus m) =>
(m a, m a) -> (m a, m a) -> (m a, m a)
plus
                    ([(Name
name, (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t,  Maybe (Typed [IOPair Type])
forall a. Maybe a
Nothing))   | (Name
name, Type
t)    <- TyConLib -> [Dec] -> [(Name, Type)]
parseTypes TyConLib
tcl [Dec]
ds] [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
-> [(Name, (Maybe Type, Maybe (Typed [IOPair Type])))]
forall a. [a] -> [a] -> [a]
++
                     [(Name
name, (Maybe Type
forall a. Maybe a
Nothing, Typed [IOPair Type] -> Maybe (Typed [IOPair Type])
forall a. a -> Maybe a
Just Typed [IOPair Type]
tiops)) | (Name
name, Typed [IOPair Type]
tiops) <- [(Name, Typed [IOPair Type])]
tups])
(m a
a,m a
b) plus :: (m a, m a) -> (m a, m a) -> (m a, m a)
`plus` (m a
c,m a
d) = (m a
a m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` m a
c, m a
b m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` m a
d)

parseTypes :: TyConLib -> [Dec] -> [(Name,T.Type)]
parseTypes :: TyConLib -> [Dec] -> [(Name, Type)]
parseTypes TyConLib
tcl [Dec]
ds = [ (Name
name, TyConLib -> Type -> Type
thTypeToType TyConLib
tcl Type
ty) | SigD Name
name Type
ty <- [Dec]
ds ]


parseIOPairss :: (Functor m, MonadPlus m) => XVarLib -> [Dec] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])]
parseIOPairss :: XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
parseIOPairss XVarLib
xvl (FunD Name
funname [Clause]
clauses : [Dec]
decs) 
    = do [Typed (IOPair Type)]
tiops <- (Clause -> PriorSubsts m (Typed (IOPair Type)))
-> [Clause] -> PriorSubsts m [Typed (IOPair Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (XVarLib -> Clause -> PriorSubsts m (Typed (IOPair Type))
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
XVarLib -> Clause -> PriorSubsts m (Typed (IOPair Type))
clauseToIOPair XVarLib
xvl) [Clause]
clauses
         let ([IOPair Type]
iops,Type
t:[Type]
ts) = [Typed (IOPair Type)] -> ([IOPair Type], [Type])
forall a. [Typed a] -> ([a], [Type])
unzipTyped [Typed (IOPair Type)]
tiops
         Type
ty <- (Type -> Type -> PriorSubsts m Type)
-> Type -> [Type] -> PriorSubsts m Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Type -> Type -> PriorSubsts m Type
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m Type
mgtPS Type
t [Type]
ts
         Subst
s <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
         let hd :: (Name, Typed [IOPair Type])
hd = (Name
funname, (IOPair Type -> IOPair Type) -> [IOPair Type] -> [IOPair Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> IOPair Type -> IOPair Type
tapplyIOP Subst
s) [IOPair Type]
iops [IOPair Type] -> Type -> Typed [IOPair Type]
forall a. a -> Type -> Typed a
T.::: Type
ty)
         [(Name, Typed [IOPair Type])]
tl <- XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
parseIOPairss XVarLib
xvl [Dec]
decs
         [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Typed [IOPair Type])]
 -> PriorSubsts m [(Name, Typed [IOPair Type])])
-> [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall a b. (a -> b) -> a -> b
$ (Name, Typed [IOPair Type])
hd(Name, Typed [IOPair Type])
-> [(Name, Typed [IOPair Type])] -> [(Name, Typed [IOPair Type])]
forall a. a -> [a] -> [a]
:[(Name, Typed [IOPair Type])]
tl
parseIOPairss XVarLib
xvl (ValD (VarP Name
name) (NormalB Exp
ex) [] : [Dec]
decs)
    = do (Expr Type
vout, IntMap Type
_intmap) <- StateT (IntMap Type) (PriorSubsts m) (Expr Type)
-> IntMap Type -> PriorSubsts m (Expr Type, IntMap Type)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Expr () -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a.
(Functor m, MonadPlus m) =>
Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
inferType (XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
xvl Exp
ex)) IntMap Type
forall a. IntMap a
IntMap.empty
         let hd :: (Name, Typed [IOPair Type])
hd = (Name
name,    [Int -> [Expr Type] -> Expr Type -> IOPair Type
forall a. Int -> [Expr a] -> Expr a -> IOPair a
IOP Int
0 [] Expr Type
vout] [IOPair Type] -> Type -> Typed [IOPair Type]
forall a. a -> Type -> Typed a
T.::: Expr Type -> Type
forall a. Expr a -> a
ann Expr Type
vout)
         [(Name, Typed [IOPair Type])]
tl <- XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
parseIOPairss XVarLib
xvl [Dec]
decs
         [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Typed [IOPair Type])]
 -> PriorSubsts m [(Name, Typed [IOPair Type])])
-> [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall a b. (a -> b) -> a -> b
$ (Name, Typed [IOPair Type])
hd(Name, Typed [IOPair Type])
-> [(Name, Typed [IOPair Type])] -> [(Name, Typed [IOPair Type])]
forall a. a -> [a] -> [a]
:[(Name, Typed [IOPair Type])]
tl
parseIOPairss XVarLib
xvl (Dec
_:[Dec]
decs) = XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
XVarLib -> [Dec] -> PriorSubsts m [(Name, Typed [IOPair Type])]
parseIOPairss XVarLib
xvl [Dec]
decs
parseIOPairss XVarLib
_   []       = [(Name, Typed [IOPair Type])]
-> PriorSubsts m [(Name, Typed [IOPair Type])]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- 型宣言がある場合，そのforallなやつにマッチして終了．
-- ない場合，そのまま関数にして終了．
clauseToIOPair :: (Functor m, MonadPlus m) => XVarLib -> Clause -> PriorSubsts m (T.Typed (IOPair T.Type))
clauseToIOPair :: XVarLib -> Clause -> PriorSubsts m (Typed (IOPair Type))
clauseToIOPair XVarLib
ivl Clause
cl = ((Typed (IOPair Type), IntMap Type) -> Typed (IOPair Type))
-> PriorSubsts m (Typed (IOPair Type), IntMap Type)
-> PriorSubsts m (Typed (IOPair Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Typed (IOPair Type), IntMap Type) -> Typed (IOPair Type)
forall a b. (a, b) -> a
fst (PriorSubsts m (Typed (IOPair Type), IntMap Type)
 -> PriorSubsts m (Typed (IOPair Type)))
-> PriorSubsts m (Typed (IOPair Type), IntMap Type)
-> PriorSubsts m (Typed (IOPair Type))
forall a b. (a -> b) -> a -> b
$ StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type))
-> IntMap Type -> PriorSubsts m (Typed (IOPair Type), IntMap Type)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (XVarLib
-> Clause
-> StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type))
forall (m :: * -> *).
MonadPlus m =>
XVarLib
-> Clause
-> StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type))
clauseToIOPair' XVarLib
ivl Clause
cl) IntMap Type
forall a. IntMap a
IntMap.empty
clauseToIOPair' :: XVarLib
-> Clause
-> StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type))
clauseToIOPair' XVarLib
ivl (Clause [Pat]
inpats (NormalB Exp
ex) []) =do [Expr Type]
ins <- (Expr () -> StateT (IntMap Type) (PriorSubsts m) (Expr Type))
-> [Expr ()] -> StateT (IntMap Type) (PriorSubsts m) [Expr Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr () -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a.
(Functor m, MonadPlus m) =>
Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
inferT ([Expr ()] -> [Expr ()]
forall a. [a] -> [a]
reverse ([Expr ()] -> [Expr ()]) -> [Expr ()] -> [Expr ()]
forall a b. (a -> b) -> a -> b
$ (Pat -> Expr ()) -> [Pat] -> [Expr ()]
forall a b. (a -> b) -> [a] -> [b]
map (XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl) [Pat]
inpats)
                                                        Expr Type
vout <- Expr () -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a.
(Functor m, MonadPlus m) =>
Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
inferT (XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
ex)
                                                        Type
ty <- PriorSubsts m Type -> StateT (IntMap Type) (PriorSubsts m) Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PriorSubsts m Type -> StateT (IntMap Type) (PriorSubsts m) Type)
-> PriorSubsts m Type -> StateT (IntMap Type) (PriorSubsts m) Type
forall a b. (a -> b) -> a -> b
$ Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS ([Type] -> Type -> Type
T.popArgs ((Expr Type -> Type) -> [Expr Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Expr Type -> Type
forall a. Expr a -> a
ann [Expr Type]
ins) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expr Type -> Type
forall a. Expr a -> a
ann Expr Type
vout)
                                                        Typed (IOPair Type)
-> StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type))
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed (IOPair Type)
 -> StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type)))
-> Typed (IOPair Type)
-> StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type))
forall a b. (a -> b) -> a -> b
$ [Expr Type] -> Expr Type -> IOPair Type
forall a. [Expr a] -> Expr a -> IOPair a
normalizeMkIOP [Expr Type]
ins Expr Type
vout IOPair Type -> Type -> Typed (IOPair Type)
forall a. a -> Type -> Typed a
T.::: Type
ty
clauseToIOPair' XVarLib
_ Clause
_ = String
-> StateT (IntMap Type) (PriorSubsts m) (Typed (IOPair Type))
forall a. HasCallStack => String -> a
error String
"Neither _guards_ nor _where_clauses_ are permitted in clauses representing I/O pairs." 
-- In future where-clauses might be supported.


matchType :: (Functor m, MonadPlus m) => [T.Type] -> T.Type -> T.Type -> PriorSubsts m ()
matchType :: [Type] -> Type -> Type -> PriorSubsts m ()
matchType [Type]
argtys Type
retty Type
ty = [Type] -> Type -> Type -> PriorSubsts m Subst
forall (m :: * -> *).
MonadPlus m =>
[Type] -> Type -> Type -> PriorSubsts m Subst
mguType [Type]
argtys Type
retty (Type -> Type
T.quantify Type
ty) PriorSubsts m Subst -> PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Subst -> m Subst) -> PriorSubsts m ()
forall (m :: * -> *).
Monad m =>
(Subst -> m Subst) -> PriorSubsts m ()
updateSubstPS (Subst -> m Subst
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst -> m Subst) -> (Subst -> Subst) -> Subst -> m Subst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> Subst
forall a. [(a, Type)] -> [(a, Type)]
unquantifySubst)
unquantifySubst :: [(a, Type)] -> [(a, Type)]
unquantifySubst = ((a, Type) -> (a, Type)) -> [(a, Type)] -> [(a, Type)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
v,Type
t) -> (a
v, Type -> Type
T.unquantify Type
t))
mguType :: [Type] -> Type -> Type -> PriorSubsts m Subst
mguType (Type
t:[Type]
ts) Type
r (Type
u T.:->Type
v) = do Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
t Type
u
                                 Subst
s <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
                                 [Type] -> Type -> Type -> PriorSubsts m Subst
mguType ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Type -> Type
T.apply Subst
s) [Type]
ts) (Subst -> Type -> Type
T.apply Subst
s Type
r) Type
v
mguType []     Type
r Type
v       = Type -> Type -> PriorSubsts m Subst
forall (m :: * -> *). MonadPlus m => Type -> Type -> m Subst
T.mgu Type
r Type
v
mguType (Type
_:[Type]
_)  Type
_ Type
_       = String -> PriorSubsts m Subst
forall a. HasCallStack => String -> a
error String
"Not enough arguments supplied."


inferType, inferT :: (Functor m, MonadPlus m) => Expr a -> StateT (IntMap.IntMap T.Type) (PriorSubsts m) (Expr T.Type)
inferType :: Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
inferType Expr a
e = do Expr Type
e' <- Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a.
(Functor m, MonadPlus m) =>
Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
inferT Expr a
e
                 Subst
s <- PriorSubsts m Subst -> StateT (IntMap Type) (PriorSubsts m) Subst
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
                 Expr Type -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Type -> StateT (IntMap Type) (PriorSubsts m) (Expr Type))
-> Expr Type -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall a b. (a -> b) -> a -> b
$ Subst -> Expr Type -> Expr Type
tapplyExpr Subst
s Expr Type
e'
inferT :: Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
inferT v :: Expr a
v@(U a
_ Int
i) = do 
                    IntMap Type
tenv <- StateT (IntMap Type) (PriorSubsts m) (IntMap Type)
forall s (m :: * -> *). MonadState s m => m s
get
                    case Int -> IntMap Type -> Maybe Type
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i IntMap Type
tenv of
                        Maybe Type
Nothing -> do TyVar
tvid <- PriorSubsts m TyVar -> StateT (IntMap Type) (PriorSubsts m) TyVar
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift PriorSubsts m TyVar
forall (m :: * -> *). Monad m => PriorSubsts m TyVar
newTVar
                                      let ty :: Type
ty = TyVar -> Type
T.TV TyVar
tvid
                                      IntMap Type -> StateT (IntMap Type) (PriorSubsts m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IntMap Type -> StateT (IntMap Type) (PriorSubsts m) ())
-> IntMap Type -> StateT (IntMap Type) (PriorSubsts m) ()
forall a b. (a -> b) -> a -> b
$ Int -> Type -> IntMap Type -> IntMap Type
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i Type
ty IntMap Type
tenv
                                      Expr Type -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Int -> Expr Type
forall a. a -> Int -> Expr a
U Type
ty Int
i)
                        Just Type
ty -> do Type
apty <- PriorSubsts m Type -> StateT (IntMap Type) (PriorSubsts m) Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PriorSubsts m Type -> StateT (IntMap Type) (PriorSubsts m) Type)
-> PriorSubsts m Type -> StateT (IntMap Type) (PriorSubsts m) Type
forall a b. (a -> b) -> a -> b
$ Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
ty
                                      Expr Type -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Int -> Expr Type
forall a. a -> Int -> Expr a
U Type
apty Int
i)
inferT (C a
_ Int
sz (Var
i T.:::Type
ty) [Expr a]
es)
                       = do [Expr Type]
es' <- (Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type))
-> [Expr a] -> StateT (IntMap Type) (PriorSubsts m) [Expr Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (m :: * -> *) a.
(Functor m, MonadPlus m) =>
Expr a -> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
inferT [Expr a]
es
                            PriorSubsts m (Expr Type)
-> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PriorSubsts m (Expr Type)
 -> StateT (IntMap Type) (PriorSubsts m) (Expr Type))
-> PriorSubsts m (Expr Type)
-> StateT (IntMap Type) (PriorSubsts m) (Expr Type)
forall a b. (a -> b) -> a -> b
$ do let tvs :: [TyVar]
tvs = ([TyVar] -> TyVar) -> [[TyVar]] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map [TyVar] -> TyVar
forall a. [a] -> a
head ([[TyVar]] -> [TyVar]) -> [[TyVar]] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [[TyVar]]
forall a. Eq a => [a] -> [[a]]
group ([TyVar] -> [[TyVar]]) -> [TyVar] -> [[TyVar]]
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [TyVar]
forall a. Ord a => [a] -> [a]
sort ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ Type -> [TyVar]
T.tyvars Type
ty
                                      TyVar
tvid <- TyVar -> PriorSubsts m TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars (TyVar -> PriorSubsts m TyVar) -> TyVar -> PriorSubsts m TyVar
forall a b. (a -> b) -> a -> b
$ [TyVar] -> TyVar
forall i a. Num i => [a] -> i
genericLength [TyVar]
tvs
                                      let apty :: Type
apty = Subst -> Type -> Type
T.apply ([TyVar] -> [Type] -> Subst
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
tvs ([Type] -> Subst) -> [Type] -> Subst
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
T.TV [TyVar
tvid..]) Type
ty
                                      Type
rty <- (Type -> Type -> PriorSubsts m Type)
-> Type -> [Type] -> PriorSubsts m Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Type -> Type -> PriorSubsts m Type
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m Type
funApM Type
apty ([Type] -> PriorSubsts m Type) -> [Type] -> PriorSubsts m Type
forall a b. (a -> b) -> a -> b
$ (Expr Type -> Type) -> [Expr Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Expr Type -> Type
forall a. Expr a -> a
ann [Expr Type]
es'
                                      Type
rapty <- Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
rty
                                      Expr Type -> PriorSubsts m (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Type -> PriorSubsts m (Expr Type))
-> Expr Type -> PriorSubsts m (Expr Type)
forall a b. (a -> b) -> a -> b
$ Type -> Int -> Typed Var -> [Expr Type] -> Expr Type
forall a. a -> Int -> Typed Var -> [Expr a] -> Expr a
C Type
rapty Int
sz (Var
i Var -> Type -> Typed Var
forall a. a -> Type -> Typed a
T.:::Type
apty) [Expr Type]
es'
funApM :: (Functor m, MonadPlus m) => T.Type -> T.Type -> PriorSubsts m T.Type
funApM :: Type -> Type -> PriorSubsts m Type
funApM (Type
a T.:-> Type
r) Type
t = Type -> Type -> Type -> PriorSubsts m Type
forall (m :: * -> *).
MonadPlus m =>
Type -> Type -> Type -> PriorSubsts m Type
fAM Type
a Type
r Type
t
funApM (Type
a T.:>  Type
r) Type
t = Type -> Type -> Type -> PriorSubsts m Type
forall (m :: * -> *).
MonadPlus m =>
Type -> Type -> Type -> PriorSubsts m Type
fAM Type
a Type
r Type
t
funApM (T.TV TyVar
i)    Type
t = do TyVar
tvid <- PriorSubsts m TyVar
forall (m :: * -> *). Monad m => PriorSubsts m TyVar
newTVar
                          Subst -> PriorSubsts m ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS [(TyVar
i,Type
t Type -> Type -> Type
T.:->TyVar -> Type
T.TV TyVar
tvid)]
                          Type -> PriorSubsts m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PriorSubsts m Type) -> Type -> PriorSubsts m Type
forall a b. (a -> b) -> a -> b
$ TyVar -> Type
T.TV TyVar
tvid
funApM Type
_         Type
_ = String -> PriorSubsts m Type
forall a. HasCallStack => String -> a
error String
"too many arguments applied."
fAM :: Type -> Type -> Type -> PriorSubsts m Type
fAM Type
apa Type
r Type
t = do Type
apt <- Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
t
                 Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
apa Type
apt
                 Type -> PriorSubsts m Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
r
tapplyIOP :: T.Subst -> IOPair T.Type -> IOPair T.Type
tapplyIOP :: Subst -> IOPair Type -> IOPair Type
tapplyIOP Subst
s (IOP Int
bvs [Expr Type]
ins Expr Type
out) = Int -> [Expr Type] -> Expr Type -> IOPair Type
forall a. Int -> [Expr a] -> Expr a -> IOPair a
IOP Int
bvs ((Expr Type -> Expr Type) -> [Expr Type] -> [Expr Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Expr Type -> Expr Type
tapplyExpr Subst
s) [Expr Type]
ins) (Subst -> Expr Type -> Expr Type
tapplyExpr Subst
s Expr Type
out)

tapplyExpr :: T.Subst -> Expr T.Type -> Expr T.Type
tapplyExpr :: Subst -> Expr Type -> Expr Type
tapplyExpr Subst
sub (C Type
t Int
sz (Var
i T.:::Type
cty) [Expr Type]
es) = Type -> Int -> Typed Var -> [Expr Type] -> Expr Type
forall a. a -> Int -> Typed Var -> [Expr a] -> Expr a
C (Subst -> Type -> Type
T.apply Subst
sub Type
t) Int
sz (Var
i Var -> Type -> Typed Var
forall a. a -> Type -> Typed a
T.:::Subst -> Type -> Type
T.apply Subst
sub Type
cty) ((Expr Type -> Expr Type) -> [Expr Type] -> [Expr Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Expr Type -> Expr Type
tapplyExpr Subst
sub) [Expr Type]
es)
tapplyExpr Subst
_   Expr Type
v               = Expr Type
v
{-
substitutionを一度getしたら，それを全体に波及させる必要がある？
てゆーか，各コンストラクタのforallでfreshVarしたやつだけすればよい？
考えるの面倒くさいし，律速ではないので2パスで．
-}

-- MagicHaskeller.Typesに置くべきという気がしないでもない．
unzipTyped :: [Typed a] -> ([a], [Type])
unzipTyped [] = ([],[])
unzipTyped ((a
e T.:::Type
t):[Typed a]
ets) = let ([a]
es,[Type]
ts) = [Typed a] -> ([a], [Type])
unzipTyped [Typed a]
ets in (a
ea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
es,Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts)


getMbTypedConstr :: XVarLib -> Name -> Maybe (T.Typed Constr)
getMbTypedConstr :: XVarLib -> Name -> Maybe (Typed Var)
getMbTypedConstr XVarLib
xvl Name
name = (Var -> Typed Var) -> Maybe Var -> Maybe (Typed Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XVarLib -> Var -> Typed Var
mkTypedConstr XVarLib
xvl) (Maybe Var -> Maybe (Typed Var)) -> Maybe Var -> Maybe (Typed Var)
forall a b. (a -> b) -> a -> b
$ String -> Map String Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Name -> String
nameBase Name
name) (XVarLib -> Map String Var
invVarLib XVarLib
xvl)
getTypedConstr :: XVarLib -> Name -> T.Typed Constr
getTypedConstr :: XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
xvl Name
name = case String -> Map String Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Name -> String
nameBase Name
name) (Map String Var -> Maybe Var) -> Map String Var -> Maybe Var
forall a b. (a -> b) -> a -> b
$ XVarLib -> Map String Var
invVarLib XVarLib
xvl of Just Var
c -> XVarLib -> Var -> Typed Var
mkTypedConstr XVarLib
xvl Var
c
                                                                             Maybe Var
Nothing -> String -> Typed Var
forall a. HasCallStack => String -> a
error (String
"could not find "String -> ShowS
forall a. [a] -> [a] -> [a]
++Name -> String
forall a. Show a => a -> String
show Name
name)
mkTypedConstr :: XVarLib -> Var -> Typed Var
mkTypedConstr  XVarLib
xvl Var
c   = Var
c Var -> Type -> Typed Var
forall a. a -> Type -> Typed a
T.::: Dynamic -> Type
PD.dynType (XVarLib -> VarLib
varLib XVarLib
xvlVarLib -> Var -> Dynamic
forall i e. Ix i => Array i e -> i -> e
!Var
c)
patToExp :: XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl (LitP (IntegerL Integer
i)) | Integer
iInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>=Integer
0      = XVarLib -> Integer -> Expr ()
forall t. (Eq t, Num t) => XVarLib -> t -> Expr ()
natToConExp XVarLib
ivl Integer
i
                                 | Bool
otherwise = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Var -> Typed Var
mkTypedConstr XVarLib
ivl (XVarLib -> Var
negateID XVarLib
ivl)) [XVarLib -> Integer -> Expr ()
forall t. (Eq t, Num t) => XVarLib -> t -> Expr ()
natToConExp XVarLib
ivl (-Integer
i)]
-- patToExp tcl (LitP (CharL c))     = C (Ctor (ord c) (cに相当する奴. ある訳ない?)) []
-- patToExp tcl (LitP (StringL str)) = strToConExp tcl str
patToExp XVarLib
ivl (VarP Name
name)   = () -> Int -> Expr ()
forall a. a -> Int -> Expr a
U () (String -> Int
strToInt (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name)
patToExp XVarLib
ivl (TupP [Pat]
pats)         = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl (Int -> Name
tupleDataName ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats))) ((Pat -> Expr ()) -> [Pat] -> [Expr ()]
forall a b. (a -> b) -> [a] -> [b]
map (XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl) [Pat]
pats)
patToExp XVarLib
ivl (ConP Name
name [Pat]
pats)    = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl Name
name)                          ((Pat -> Expr ()) -> [Pat] -> [Expr ()]
forall a b. (a -> b) -> [a] -> [b]
map (XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl) [Pat]
pats)
patToExp XVarLib
ivl (InfixP Pat
p1 Name
name Pat
p2) = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl Name
name)                          ((Pat -> Expr ()) -> [Pat] -> [Expr ()]
forall a b. (a -> b) -> [a] -> [b]
map (XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl) [Pat
p1,Pat
p2])
patToExp XVarLib
ivl (TildeP Pat
p)    = XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl Pat
p
patToExp XVarLib
ivl (AsP Name
_ Pat
_)     = String -> Expr ()
forall a. HasCallStack => String -> a
error String
"As (@) patterns not supported."
patToExp XVarLib
ivl Pat
WildP         = () -> Int -> Expr ()
forall a. a -> Int -> Expr a
U () (String -> Int
strToInt String
"_") -- will not work correctly if there are more than one wildcards in one I/O pair, I think.
patToExp XVarLib
ivl (RecP Name
_ [FieldPat]
_)    = String -> Expr ()
forall a. HasCallStack => String -> a
error String
"Record patterns not supported."
patToExp XVarLib
ivl (ListP [Pat]
pats)  = (Expr () -> Expr () -> Expr ()) -> Expr () -> [Expr ()] -> Expr ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Expr () -> Expr () -> Expr ()
cons Expr ()
nil ([Expr ()] -> Expr ()) -> [Expr ()] -> Expr ()
forall a b. (a -> b) -> a -> b
$ (Pat -> Expr ()) -> [Pat] -> [Expr ()]
forall a b. (a -> b) -> [a] -> [b]
map (XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl) [Pat]
pats 
    where nil :: Expr ()
nil        = () -> Int -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Int -> Typed Var -> [Expr a] -> Expr a
C () Int
1 (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl '[]) []
          cons :: Expr () -> Expr () -> Expr ()
cons Expr ()
e1 Expr ()
e2 = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl '(:)) [Expr ()
e1,Expr ()
e2]
patToExp XVarLib
ivl (SigP Pat
pat Type
_t) = XVarLib -> Pat -> Expr ()
patToExp XVarLib
ivl Pat
pat -- Or should this cause an error?

-- Is this encoding really quicker than raw String (or maybe PackedString)?
strToInt :: String -> Int
strToInt [] = Int
1
strToInt (Char
x:String
xs) = Char -> Int
ord Char
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
strToInt String
xs

natLimit :: Integer
natLimit = Integer
32
natToConExp :: XVarLib -> t -> Expr ()
natToConExp XVarLib
ivl t
i -- x | i > natLimit = C (Ctor i  (iに相当する奴. ある訳ない?)) []
                  | Bool
otherwise    = XVarLib -> t -> Expr ()
forall t. (Eq t, Num t) => XVarLib -> t -> Expr ()
smallNat XVarLib
ivl t
i
smallNat :: XVarLib -> t -> Expr ()
smallNat XVarLib
ivl t
0 = () -> Int -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Int -> Typed Var -> [Expr a] -> Expr a
C () Int
1 (XVarLib -> Var -> Typed Var
mkTypedConstr XVarLib
ivl (XVarLib -> Var
zeroID XVarLib
ivl)) []
smallNat XVarLib
ivl t
i = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Var -> Typed Var
mkTypedConstr XVarLib
ivl (XVarLib -> Var
succID XVarLib
ivl)) [XVarLib -> t -> Expr ()
smallNat XVarLib
ivl (t
it -> t -> t
forall a. Num a => a -> a -> a
-t
1)]
-- strToConExp tcl "" = C (Ctor 0 ([]に相当する奴)) []

thExpToExpr :: XVarLib -> Exp -> Expr ()
thExpToExpr :: XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl (VarE Name
name) = case XVarLib -> Name -> Maybe (Typed Var)
getMbTypedConstr XVarLib
ivl Name
name of Maybe (Typed Var)
Nothing -> () -> Int -> Expr ()
forall a. a -> Int -> Expr a
U () (String -> Int
strToInt (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name)
                                                                Just Typed Var
x  -> () -> Int -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Int -> Typed Var -> [Expr a] -> Expr a
C () Int
1 Typed Var
x []
thExpToExpr XVarLib
ivl (ConE Name
name) = () -> Int -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Int -> Typed Var -> [Expr a] -> Expr a
C () Int
1 (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl Name
name) []
thExpToExpr XVarLib
ivl (LitE (IntegerL Integer
i)) | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0    = XVarLib -> Integer -> Expr ()
forall t. (Eq t, Num t) => XVarLib -> t -> Expr ()
natToConExp XVarLib
ivl Integer
i
                                    | Bool
otherwise = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Var -> Typed Var
mkTypedConstr XVarLib
ivl (XVarLib -> Var
negateID XVarLib
ivl)) [XVarLib -> Integer -> Expr ()
forall t. (Eq t, Num t) => XVarLib -> t -> Expr ()
natToConExp XVarLib
ivl (-Integer
i)]
thExpToExpr XVarLib
ivl (AppE Exp
f Exp
x)  = case XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
f of C () Int
sz Typed Var
c [Expr ()]
xs -> let thx :: Expr ()
thx = XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
x
                                                                        in () -> Int -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Int -> Typed Var -> [Expr a] -> Expr a
C () (Int
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Expr () -> Int
forall a. Expr a -> Int
size Expr ()
thx) Typed Var
c ([Expr ()]
xs [Expr ()] -> [Expr ()] -> [Expr ()]
forall a. [a] -> [a] -> [a]
++ [Expr ()
thx])  -- O(n^2)
                                                        U () Int
_    -> String -> Expr ()
forall a. HasCallStack => String -> a
error String
"Only constructor applications are permitted in IO examples."
thExpToExpr XVarLib
ivl (InfixE (Just Exp
x) (ConE Name
name) (Just Exp
y)) = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl Name
name) [XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
x, XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
y]
thExpToExpr XVarLib
ivl (InfixE (Just Exp
x) (VarE Name
name) (Just Exp
y)) = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl Name
name) [XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
x, XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
y]
thExpToExpr XVarLib
ivl (TupE [Maybe Exp]
es) = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl (Int -> Name
tupleDataName ([Maybe Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Exp]
es))) ((Maybe Exp -> Expr ()) -> [Maybe Exp] -> [Expr ()]
forall a b. (a -> b) -> [a] -> [b]
map (XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl (Exp -> Expr ()) -> (Maybe Exp -> Exp) -> Maybe Exp -> Expr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Exp -> Exp
forall a. Maybe a -> a
unJust) [Maybe Exp]
es)
thExpToExpr XVarLib
ivl (ListE [Exp]
es) = (Expr () -> Expr () -> Expr ()) -> Expr () -> [Expr ()] -> Expr ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Expr () -> Expr () -> Expr ()
cons Expr ()
nil ([Expr ()] -> Expr ()) -> [Expr ()] -> Expr ()
forall a b. (a -> b) -> a -> b
$ (Exp -> Expr ()) -> [Exp] -> [Expr ()]
forall a b. (a -> b) -> [a] -> [b]
map (XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl) [Exp]
es 
    where nil :: Expr ()
nil        = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl '[]) []
          cons :: Expr () -> Expr () -> Expr ()
cons Expr ()
e1 Expr ()
e2 = () -> Typed Var -> [Expr ()] -> Expr ()
forall a. a -> Typed Var -> [Expr a] -> Expr a
cap () (XVarLib -> Name -> Typed Var
getTypedConstr XVarLib
ivl '(:)) [Expr ()
e1,Expr ()
e2]
thExpToExpr XVarLib
ivl (SigE Exp
e Type
_t) = XVarLib -> Exp -> Expr ()
thExpToExpr XVarLib
ivl Exp
e
thExpToExpr XVarLib
_ Exp
_ = String -> Expr ()
forall a. HasCallStack => String -> a
error String
"Unsupported expression in IO examples."
{-
caseの場合，既にあるprimitive componentに合わせるのは結構ややこしい．（たとえば，コンストラクタの順序づけとかを合わせるのはってことね．）
コンストラクタの順序づけはreifyでゲットした順にすることにして，caseは直接THを生成することにする．
これが可能なのは，まずanalyticalやってそれからsystematicをやるから．

そうなると，clauseToIOPairとかにVarLibはいらなくなるし，ConstrはCoreExprの代わりにTH.Exp(かTH.Name)を持つことになる．
-}