exference (empty) → 1.6.0.0

raw patch · 73 files changed

+6951/−0 lines, 73 filesdep +basedep +base-orphansdep +bifunctorssetup-changed

Dependencies added: base, base-orphans, bifunctors, containers, data-pprint, deepseq, deepseq-generics, directory, either, exference, hashable, haskell-src-exts, hood, lens, mmorph, mtl, multistate, parsec, pqueue, pretty, process, safe, split, template-haskell, transformers, unordered-containers, vector

Files

LICENSE +25/−0
Setup.hs +2/−0
environment/Applicative.hs +40/−0
environment/Arrow.hs +22/−0
environment/Bits.hs +7/−0
environment/Bool.hs +24/−0
environment/Category.hs +7/−0
environment/Char.hs +23/−0
environment/Comonad.hs +19/−0
environment/Complex.hs +17/−0
environment/Cont.hs +9/−0
environment/ControlMonadIOClass.hs +6/−0
environment/ControlMonadTransClass.hs +6/−0
environment/Data.hs +94/−0
environment/DataFunction.hs +5/−0
environment/Either.hs +24/−0
environment/EitherT.hs +9/−0
environment/Eq.hs +42/−0
environment/Foldable.hs +21/−0
environment/Functor.hs +29/−0
environment/Generics.hs +20/−0
environment/Int.hs +90/−0
environment/Ix.hs +37/−0
environment/List.hs +23/−0
environment/Map.hs +7/−0
environment/Maybe.hs +29/−0
environment/Monad.hs +36/−0
environment/MonadLoops.hs +18/−0
environment/Monoid.hs +41/−0
environment/Ord.hs +54/−0
environment/Prelude.hs +119/−0
environment/Printf.hs +7/−0
environment/Proxy.hs +22/−0
environment/Ratio.hs +21/−0
environment/Read.hs +16/−0
environment/Show.hs +46/−0
environment/State.hs +22/−0
environment/Storable.hs +12/−0
environment/String.hs +6/−0
environment/SystemIO.hs +11/−0
environment/Text.hs +20/−0
environment/Traversable.hs +17/−0
environment/Typeable.hs +22/−0
environment/Void.hs +23/−0
environment/Word.hs +90/−0
environment/all.ratings +112/−0
exference.cabal +245/−0
src-exference/Main.hs +385/−0
src-exference/MainConfig.hs +111/−0
src-exference/MainTest.hs +657/−0
src/Flags_exference.hs +19/−0
src/Language/Haskell/Exference.hs +193/−0
src/Language/Haskell/Exference/BindingsFromHaskellSrc.hs +204/−0
src/Language/Haskell/Exference/ClassEnvFromHaskellSrc.hs +165/−0
src/Language/Haskell/Exference/Core.hs +31/−0
src/Language/Haskell/Exference/Core/ExferenceStats.hs +15/−0
src/Language/Haskell/Exference/Core/Expression.hs +219/−0
src/Language/Haskell/Exference/Core/ExpressionSimplify.hs +147/−0
src/Language/Haskell/Exference/Core/FunctionBinding.hs +24/−0
src/Language/Haskell/Exference/Core/Internal/ConstraintSolver.hs +64/−0
src/Language/Haskell/Exference/Core/Internal/Exference.hs +648/−0
src/Language/Haskell/Exference/Core/Internal/ExferenceNode.hs +348/−0
src/Language/Haskell/Exference/Core/Internal/ExferenceNodeBuilder.hs +86/−0
src/Language/Haskell/Exference/Core/Internal/Unify.hs +249/−0
src/Language/Haskell/Exference/Core/SearchTree.hs +86/−0
src/Language/Haskell/Exference/Core/TypeUtils.hs +125/−0
src/Language/Haskell/Exference/Core/Types.hs +399/−0
src/Language/Haskell/Exference/EnvironmentParser.hs +327/−0
src/Language/Haskell/Exference/ExpressionToHaskellSrc.hs +193/−0
src/Language/Haskell/Exference/FunctionDecl.hs +27/−0
src/Language/Haskell/Exference/SimpleDict.hs +213/−0
src/Language/Haskell/Exference/TypeDeclsFromHaskellSrc.hs +174/−0
src/Language/Haskell/Exference/TypeFromHaskellSrc.hs +245/−0

+ LICENSE view

@@ -0,0 +1,25 @@+Copyright 2014-2017 Lennart Spitzner++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.+  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.+  * The names of this library's contributors may not be used to endorse or+    promote products derived from this software without specific prior+    written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ environment/Applicative.hs view

@@ -0,0 +1,40 @@+module Control.Applicative where++++class Data.Functor.Functor f => Applicative f where+  pure :: a -> f a+  (<*>) :: f (a->b) -> f a -> f b++class Applicative f => Alternative f where+  -- empty :: f a+  (<|>) :: f a -> f a -> f a+  -- some :: f a -> f [a]+  -- many :: f a -> f [a] ++liftA2 :: Applicative f => (a1 -> a2 -> r) -> f a1 -> f a2 -> f r+liftA3 :: Applicative f => (a1 -> a2 -> a3 -> r) -> f a1 -> f a2 -> f a3 -> f r ++instance Data.Monoid.Monoid a => Applicative ((,) a)+instance Arrow a => Applicative (ArrowMonad a)+instance Control.Monad.Monad m => Applicative (Control.Monad.WrappedMonad m)+instance Data.Monoid.Monoid m => Applicative (Const m)+instance Arrow a => Applicative (WrappedArrow a b)+-- instance Typeable ((* -> *) -> Constraint) Applicative++instance Alternative []+instance ArrowPlus a => Alternative (ArrowMonad a)+instance Control.Monad.MonadPlus m => Alternative (WrappedMonad m)+-- instance Alternative f => Alternative (Alt * f)+instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b)++data ZipList a++instance Data.Functor.Functor ZipList+instance Control.Applicative.Applicative ZipList+instance GHC.Generics.Generic1 ZipList+instance Data.Eq.Eq a => Data.Eq.Eq (ZipList a)+instance Data.Ord.Ord a => Data.Ord.Ord (ZipList a)+instance Text.Read.Read a => Text.Read.Read (ZipList a)+instance Text.Show.Show a => Text.Show.Show (ZipList a)+instance GHC.Generics.Generic (ZipList a)

+ environment/Arrow.hs view

@@ -0,0 +1,22 @@+module Control.Arrow where++++class Category a => Arrow a where+  arr :: (b -> c) -> a b c+  first :: a b c -> a (b, d) (c, d)+  second :: a b c -> a (d, b) (d, c)+  (***) :: a b c -> a b' c' -> a (b, b') (c, c')+  (&&&) :: a b c -> a b c' -> a b (c, c')++instance Control.Monad m => Arrow (Kleisli m)++newtype Kleisli m a b = Kleisli (a -> m b)++class Arrow a => ArrowZero a where+  zeroArrow :: a b c++class ArrowZero a => ArrowPlus a where+  (<+>) :: a b c -> a b c -> a b c++-- TODO: there is more stuff in base:Control.Arrow

+ environment/Bits.hs view

@@ -0,0 +1,7 @@+module Data.Bits where++++class Data.Eq.Eq a => Bits a where+class Bits b => FiniteBits b where+

+ environment/Bool.hs view

@@ -0,0 +1,24 @@+module Data.Bool where++++data Bool = True+          | False++(&&) :: Bool -> Bool -> Bool+(||) :: Bool -> Bool -> Bool++bool :: a -> a -> Bool -> a ++instance Prelude.Bounded Bool+instance Prelude.Enum Bool+instance Data.Eq.Eq Bool+instance Data.Data.Data Bool+instance Data.Ord.Ord Bool+instance Text.Read.Read Bool+instance Text.Show.Show Bool+instance Data.Ix.Ix Bool+instance GHC.Generics.Generic Bool+instance Data.Bits.FiniteBits Bool+instance Data.Bits.Bits Bool+instance Foreign.Storable.Storable Bool

+ environment/Category.hs view

@@ -0,0 +1,7 @@+module Control.Category where++++class Category cat where+  id :: cat a a+  (.) :: cat b c -> cat a b -> cat a c

+ environment/Char.hs view

@@ -0,0 +1,23 @@+module Data.Char where++++data Char+++instance Prelude.Bounded Char+instance Prelude.Enum Char+instance Data.Eq.Eq Char+instance Data.Data.Data Char+instance Data.Ord.Ord Char+instance Text.Read.Read Char+instance Text.Show.Show Char+instance Data.Ix.Ix Char+instance GHC.Generics.Generic Char+instance Foreign.Storable.Storable Char+instance Text.Printf.IsChar Char  +instance Text.Printf.PrintfArg Char   +instance Data.String.IsString [Char]++ord :: Char -> Data.Int.Int+chr :: Data.Int.Int -> Char

+ environment/Comonad.hs view

@@ -0,0 +1,19 @@+module Control.Comonad where++++class Data.Functor.Functor w => Comonad w where+  -- loses information and causes search space enlarging.+  -- extract :: w a -> a+  duplicate :: w a -> w (w a)+  extend :: (w a -> b) -> w a -> w b++liftW :: Comonad w => (a -> b) -> w a -> w b++class Comonad w => ComonadApply w where+  (<@>) :: w (a -> b) -> w a -> w b+  (@>) :: w a -> w b -> w b+  (<@) :: w a -> w b -> w a++liftW2 :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c+liftW3 :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d

+ environment/Complex.hs view

@@ -0,0 +1,17 @@+module Data.Complex where++++data Complex a++instance Data.Eq.Eq a => Data.Eq.Eq (Complex a)   +instance Prelude.RealFloat a => Floating (Complex a)   +instance Prelude.RealFloat a => Fractional (Complex a)   +instance Data.Data.Data a => Data.Data.Data (Complex a)   +instance Prelude.RealFloat a => Prelude.Num (Complex a)   +instance Text.Read.Read a => Text.Read.Read (Complex a)   +instance Text.Show.Show a => Text.Show.Show (Complex a)   +instance Foreign.Storable.Storable a => Foreign.Storable.Storable (Complex a)   ++realPart :: Complex a -> a+imagPart :: Complex a -> a

+ environment/Cont.hs view

@@ -0,0 +1,9 @@+module Control.Monad.Trans.Cont where++++newtype Cont r a = Cont ((a -> r) -> r)++-- runCont :: Cont r a -> (a -> r) -> r++-- instance Control.Monad.Monad (Cont r)

+ environment/ControlMonadIOClass.hs view

@@ -0,0 +1,6 @@+module Control.Monad.IO.Class where++++class Control.Monad.Monad m => MonadIO m where+  liftIO :: System.IO.IO a -> m a

+ environment/ControlMonadTransClass.hs view

@@ -0,0 +1,6 @@+module Control.Monad.Trans.Class where++++class MonadTrans t where+    lift :: (Control.Monad.Monad m) => m a -> t m a

+ environment/Data.hs view

@@ -0,0 +1,94 @@+module Data.Data where++++data DataType+data Constr+data DataRep+data ConstrRep+data Fixity++class Typeable a => Data a where+  gfoldl  :: (forall d b. Data d => c (d -> b) -> d -> c b)+          -> (forall g. g -> c g)+          -> a+          -> c a++  gunfold :: (forall b r. Data b => c (b -> r) -> c r)+          -> (forall r. r -> c r)+          -> Constr+          -> c a++  toConstr   :: a -> Constr++  dataTypeOf  :: a -> DataType++  dataCast1 :: Typeable t+            => (forall d. Data d => c (t d))+            -> Data.Maybe.Maybe (c a)++  dataCast2 :: Typeable t+            => (forall d e. (Data d, Data e) => c (t d e))+            -> Data.Maybe.Maybe (c a)++  -- following removed for exploding the search space++  -- gmapT :: (forall b. Data b => b -> b) -> a -> a++  -- gmapQl :: forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r++  -- gmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r++  -- gmapQ :: (forall d. Data d => d -> u) -> a -> [u]++  -- gmapQi :: forall u. Data.Int.Int -> (forall d. Data d => d -> u) -> a -> u++  -- gmapM :: forall m. Control.Monad.Monad m => (forall d. Data d => d -> m d) -> a -> m a++  -- gmapMp :: forall m. Control.Monad.MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a++  -- gmapMo :: forall m. Control.Monad.MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a+++instance Data Data.Bool.Bool+instance Data Data.Char.Char+instance Data Prelude.Double+instance Data Prelude.Float+instance Data Data.Int.Int+instance Data Data.Int.Int8+instance Data Data.Int.Int16+instance Data Data.Int.Int32+instance Data Data.Int.Int64+instance Data Prelude.Integer+instance Data Data.Ord.Ordering+instance Data Data.Word.Word+instance Data Data.Word.Word8+instance Data Data.Word.Word16+instance Data Data.Word.Word32+instance Data Data.Word.Word64+instance Data ()+-- instance Data Version+-- instance Data Natural+-- instance Data SpecConstrAnnotation+instance Data Data.Void.Void+instance Data a => Data [a]+-- instance (Data a, Prelude.Integral a) => Data (Ratio a)+-- instance (Data a, Typeable * a) => Data (Ptr a)+instance Data a => Data (Data.Maybe.Maybe a)+-- instance (Data a, Typeable * a) => Data (ForeignPtr a)+-- instance Data a => Data (Complex a)+-- instance Typeable * a => Data (Fixed a)+-- instance Data a => Data (Identity a)+instance (Data a, Data b) => Data (Data.Either.Either a b)+instance (Data a, Data b) => Data (a, b)+-- instance Data t => Data (Proxy * t)+instance (Data a, Data b, Data c) => Data (a, b, c)+-- instance ((~) * a b, Data a) => Data ((:~:) * a b)+-- instance (Coercible * a b, Data a, Data b) => Data (Coercion * a b)+instance (Data a, Data b, Data c, Data d) => Data (a, b, c, d)+instance (Data a, Data b, Data c, Data d, Data e) => Data (a, b, c, d, e)+instance (Data a, Data b, Data c, Data d, Data e, Data f) => Data (a, b, c, d, e, f)+instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => Data (a, b, c, d, e, f, g)+++dataTypeConstrs :: DataType -> [Constr]

+ environment/DataFunction.hs view

@@ -0,0 +1,5 @@+module Data.Function where++++fix :: (a -> a) -> a

+ environment/Either.hs view

@@ -0,0 +1,24 @@+module Data.Either where++++data Either a b = Left a+                | Right b++-- replacable by pattern-matching; causes larger search-space+-- either :: (a->c) -> (b->c) -> Either a b -> c+partitionEithers :: [Either a b] -> ([a], [b]) ++instance Bifunctor Either+instance Control.Monad.Monad (Either e)+instance Data.Functor.Functor (Either a)+instance Control.Monad.MonadFix (Either e)+instance Control.Applicative.Applicative (Either e)+instance Data.Foldable.Foldable (Either a)+instance Data.Traversable.Travesable (Either a)+instance GHC.Generics.Generic1 (Either a)+instance (Data.Eq.Eq a, Data.Eq.Eq b) => Data.Eq.Eq (Either a b)+instance (Data.Ord.Ord a, Data.Ord.Ord b) => Data.Ord.Ord (Either a b)+instance (Text.Read.Read a, Text.Read.Read b) => Text.Read.Read (Either a b)+instance (Text.Show.Show a, Text.Show.Show b) => Text.Show.Show (Either a b)+instance GHC.Generics.Generic (Either a b)

+ environment/EitherT.hs view

@@ -0,0 +1,9 @@+module Control.Monad.Trans.Either where++++newtype EitherT e m a = EitherT (m (Data.Either.Either e a))++runEitherT :: EitherT e m a -> m (Data.Either.Either e a)++instance Control.Monad.Monad m => Control.Monad.Monad (EitherT e m)

+ environment/Eq.hs view

@@ -0,0 +1,42 @@+module Data.Eq where++++class Eq a where+  (==) :: a -> a -> Data.Bool.Bool+  (/=) :: a -> a -> Data.Bool.Bool++instance Eq a => Eq [a]+instance Eq a => Eq (Data.Ratio.Ratio a)+-- instance Eq p => Eq (Par1 p)+instance Eq a => Eq (Data.Maybe.Maybe a)+instance Eq a => Eq (Data.Ord.Down a)+instance Eq a => Eq (Data.Monoid.Last a)+instance Eq a => Eq (Data.Monoid.First a)+instance Eq a => Eq (Data.Monoid.Product a)+instance Eq a => Eq (Data.Monoid.Sum a)+instance Eq a => Eq (Data.Monoid.Dual a)+instance Eq a => Eq (ZipList a)+instance Eq a => Eq (Complex a)+instance (Eq a, Eq b) => Eq (Data.Either.Either a b)+-- instance Eq (f p) => Eq (Rec1 f p)+instance (Eq a, Eq b) => Eq (a, b)+instance Eq c => Eq (K1 i c p)+-- instance (Eq (f p), Eq (g p)) => Eq ((:+:) f g p)+-- instance (Eq (f p), Eq (g p)) => Eq ((:*:) f g p)+-- instance Eq (f (g p)) => Eq ((:.:) f g p)+instance (Eq a, Eq b, Eq c) => Eq (a, b, c)+-- instance Eq ((:~:) k a b)+-- instance Eq (f p) => Eq (M1 i c f p)+instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d)+instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => Eq (a, b, c, d, e, f)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a, b, c, d, e, f, g)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h) => Eq (a, b, c, d, e, f, g, h)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i) => Eq (a, b, c, d, e, f, g, h, i)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j) => Eq (a, b, c, d, e, f, g, h, i, j)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k) => Eq (a, b, c, d, e, f, g, h, i, j, k)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l) => Eq (a, b, c, d, e, f, g, h, i, j, k, l)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)

+ environment/Foldable.hs view

@@ -0,0 +1,21 @@+module Data.Foldable where++++class Foldable t where+  fold :: Data.Monoid.Monoid m => t m -> m+  foldMap :: Data.Monoid.Monoid m => (a -> m) -> t a -> m+  foldr :: (a -> b -> b) -> b -> t a -> b+  foldl :: (b -> a -> b) -> b -> t a -> b++asum :: (Foldable t, Control.Applicative.Alternative f)+     => t (f a)+     -> f a ++instance Foldable []+instance Foldable Data.Maybe.Maybe+instance Foldable Identity+instance Foldable (Data.Either.Either a)+instance Foldable ((,) a)+-- instance Foldable (Proxy *)+instance Foldable (Const m)

+ environment/Functor.hs view

@@ -0,0 +1,29 @@+module Data.Functor where++++class Functor f where+  fmap :: (a->b) -> f a -> f b+  -- (<$) :: a -> f b -> f a++instance Functor []+instance Functor IO+instance Functor Data.Maybe.Maybe+instance Functor ReadP+instance Functor ReadPrec+instance Functor STM+instance Functor Handler+instance Functor ZipList+instance Functor ArgDescr+instance Functor OptDescr+instance Functor ArgOrder+-- instance Functor ((->) r)+instance Functor (Data.Either.Either a)+instance Functor ((,) a)+instance Functor (ST s)+-- instance Functor (Proxy *)+instance Arrow a => Functor (ArrowMonad a)+instance Functor (ST s)+instance Control.Monad.Monad m => Functor (WrappedMonad m)+instance Functor (Const m)+instance Arrow a => Functor (WrappedArrow a b)

+ environment/Generics.hs view

@@ -0,0 +1,20 @@+module GHC.Generics where++++data V1 p+data U1 p+data Par1 p+data Rec1 f p +data K1 i c p +data M1 i c f p ++class Generic a where+class Generic1 f where++instance Generic (a, b)+instance Generic (a, b, c)+instance Generic (a, b, c, d)+instance Generic (a, b, c, d, e)+instance Generic (a, b, c, d, e, f)+instance Generic (a, b, c, d, e, f, g)

+ environment/Int.hs view

@@ -0,0 +1,90 @@+module Data.Int where++++data Int+data Int8+data Int16+data Int32+data Int64++instance Prelude.Bounded Int  +instance Prelude.Enum Int   +instance Data.Eq.Eq Int   +instance Prelude.Integral Int   +instance Data.Data.Data Int   +instance Prelude.Num Int  +instance Data.Ord.Ord Int  +instance Text.Read.Read Int   +instance Prelude.Real Int   +instance Text.Show.Show Int   +instance Data.Ix.Ix Int   +instance GHC.Generics.Generic Int  +instance Data.Bits.FiniteBits Int   +instance Data.Bits.Bits Int   +instance Foreign.Storable.Storable Int   +instance Text.Printf.PrintfArg Int  ++instance Prelude.Bounded Int8+instance Prelude.Enum Int8+instance Data.Eq.Eq Int8+instance Prelude.Integral Int8+instance Data.Data.Data Int8+instance Prelude.Num Int8+instance Data.Ord.Ord Int8+instance Text.Read.Read Int8+instance Prelude.Real Int8+instance Text.Show.Show Int8+instance Data.Ix.Ix Int8+instance Data.Bits.FiniteBits Int8+instance Data.Bits.Bits Int8+instance Foreign.Storable.Storable Int8+instance Text.Printf.PrintfArg Int8++instance Prelude.Bounded Int16+instance Prelude.Enum Int16+instance Data.Eq.Eq Int16+instance Prelude.Integral Int16+instance Data.Data.Data Int16+instance Prelude.Num Int16+instance Data.Ord.Ord Int16+instance Text.Read.Read Int16+instance Prelude.Real Int16+instance Text.Show.Show Int16+instance Data.Ix.Ix Int16+instance Data.Bits.FiniteBits Int16+instance Data.Bits.Bits Int16+instance Foreign.Storable.Storable Int16+instance Text.Printf.PrintfArg Int16++instance Prelude.Bounded Int32+instance Prelude.Enum Int32+instance Data.Eq.Eq Int32+instance Prelude.Integral Int32+instance Data.Data.Data Int32+instance Prelude.Num Int32+instance Data.Ord.Ord Int32+instance Text.Read.Read Int32+instance Prelude.Real Int32+instance Text.Show.Show Int32+instance Data.Ix.Ix Int32+instance Data.Bits.FiniteBits Int32+instance Data.Bits.Bits Int32+instance Foreign.Storable.Storable Int32+instance Text.Printf.PrintfArg Int32++instance Prelude.Bounded Int8+instance Prelude.Enum Int8+instance Data.Eq.Eq Int8+instance Prelude.Integral Int8+instance Data.Data.Data Int8+instance Prelude.Num Int8+instance Data.Ord.Ord Int8+instance Text.Read.Read Int8+instance Prelude.Real Int8+instance Text.Show.Show Int8+instance Data.Ix.Ix Int8+instance Data.Bits.FiniteBits Int8+instance Data.Bits.Bits Int8+instance Foreign.Storable.Storable Int8+instance Text.Printf.PrintfArg Int8

+ environment/Ix.hs view

@@ -0,0 +1,37 @@+module Data.Ix where++++class Data.Ord.Ord a => Ix a where+  range :: (a, a) -> [a]+  index :: (a, a) -> a -> Data.Int.Int+  inRange :: (a, a) -> a -> Data.Bool.Bool+  rangeSize :: (a, a) -> Data.Int.Int+  -- same restriction as for Bounded: better don't define instances for now.++-- instance Ix Bool+-- instance Ix Char+-- instance Ix Int+-- instance Ix Int8+-- instance Ix Int16+-- instance Ix Int32+-- instance Ix Int64+-- instance Ix Integer+-- instance Ix Ordering+-- instance Ix Word+-- instance Ix Word8+-- instance Ix Word16+-- instance Ix Word32+-- instance Ix Word64+-- instance Ix ()+-- instance Ix GeneralCategory+-- instance Ix SeekMode+-- instance Ix IOMode+-- instance Ix Natural+-- instance Ix Void+-- instance (Ix a, Ix b) => Ix (a, b)+-- instance Ix (Proxy k s)+-- instance (Ix a1, Ix a2, Ix a3) => Ix (a1, a2, a3)+-- instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1, a2, a3, a4)+-- instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1, a2, a3, a4, a5)+

+ environment/List.hs view

@@ -0,0 +1,23 @@+module Data.List where+++++zip :: [a] -> [b] -> [(a, b)]+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]+zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]+zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]+zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]+zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)]+zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]+zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]+zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]+zipWith5 :: (a -> b -> c -> d -> e -> f) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f]+zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]+zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h]+unzip :: [(a, b)] -> ([a], [b])+unzip3 :: [(a, b, c)] -> ([a], [b], [c])+unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])+unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])+unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f])+unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g])

+ environment/Map.hs view

@@ -0,0 +1,7 @@+module Data.Map where++++data Map k a++lookup :: Data.Ord.Ord k => k -> Map k a -> Data.Maybe.Maybe a

+ environment/Maybe.hs view

@@ -0,0 +1,29 @@+module Data.Maybe where++++data Maybe a = Just a+             | Nothing++maybe :: b -> (a -> b) -> Maybe a -> b+fromMaybe :: a -> Maybe a -> a+catMaybes :: [Maybe a] -> [a]+mapMaybe :: (a -> Maybe b) -> [a] -> [b]+maybeToList :: Maybe a -> [a]++instance Control.Monad.Monad Maybe+instance Data.Functor.Functor Maybe+instance Control.Monad.MonadFix Maybe+instance Control.Applicative.Applicative Maybe+instance Data.Foldable.Foldable Maybe+instance Data.Traversable.Travesable Maybe+instance GHC.Generics.Generic1 Maybe+instance Control.Monad.MonadPlus Maybe+instance Control.Applicative.Alternative Maybe+instance Data.Eq.Eq a => Data.Eq.Eq (Maybe a)+instance Data.Data.Data a => Data.Data.Data (Maybe a)+instance Data.Ord.Ord a => Data.Ord.Ord (Maybe a)+instance Text.Read.Read a => Text.Read.Read (Maybe a)+instance Text.Show.Show a => Text.Show.Show (Maybe a)+instance GHC.Generics.Generic (Maybe a)+instance Data.Monoid.Monoid a => Data.Monoid.Monoid (Maybe a)

+ environment/Monad.hs view

@@ -0,0 +1,36 @@+module Control.Monad where+++++class Control.Applicative.Applicative m => Monad m where+  (>>=) :: m a -> (a -> m b) -> m b++class (Control.Applicative.Alternative m, Monad m) => MonadPlus m where+  -- mzero :: m a -- this is a critical case: too generic, yet we might need it+                  -- at times+  -- more specific than (<|>)+  -- mplus :: m a -> m a -> m a++(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c+join :: Monad m => m (m a) -> m a+msum :: (Foldable t, MonadPlus m) => t (m a) -> m a+mfilter :: MonadPlus m => (a -> Data.Bool.Bool) -> m a -> m a +zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] +foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b +forever :: Monad m => m () -> m Void+(>>) :: Monad m => m () -> m b -> m b++instance Monad []+instance Monad IO+instance Monad Data.Maybe.Maybe+instance Monad ReadP+instance Monad ReadPrec+instance Monad STM+-- instance Monad ((->) r)+instance Monad (Data.Either.Either e)+instance Monad (ST s)+-- instance Monad (Proxy *)+instance ArrowApply a => Monad (ArrowMonad a)+instance Monad (ST s)+instance Monad m => Monad (WrappedMonad m)

+ environment/MonadLoops.hs view

@@ -0,0 +1,18 @@+module Control.Monad.Loops where++++-- whileM :: Control.Monad.Monad m => m Data.Bool.Bool -> m a -> m [a]+whileM' :: (Control.Monad.Monad m, Control.Monad.MonadPlus f) => m Data.Bool.Bool -> m a -> m (f a) +iterateWhile :: Control.Monad.Monad m => (a -> Bool) -> m a -> m a ++-- this is evil, prove-wise+iterateM_ :: Control.Monad.Monad m => (a -> m a) -> a -> m b++-- untilM :: Control.Monad.Monad m => m a -> m Data.Bool.Bool -> m [a]+untilM' :: (Control.Monad.Monad m, Control.Monad.MonadPlus f) => m a -> m Data.Bool.Bool -> m (f a)++-- this is evil, in it discards results+-- iterateWhile :: Control.Monad.Monad m => (a -> Data.Bool.Bool) -> m a -> m a++concatM :: Control.Monad.Monad m => [a -> m a] -> a -> m a

+ environment/Monoid.hs view

@@ -0,0 +1,41 @@+module Data.Monoid where++++class Monoid a where+  mempty :: a+  mappend :: a -> a -> a+  mconcat :: [a] -> a+++instance Monoid Ordering  +instance Monoid ()  +instance Monoid Any   +instance Monoid All   +instance Monoid Event   +instance Monoid [a]   +instance Monoid a => Monoid (Maybe a)  +instance Monoid (Last a)  +instance Monoid (First a)   +instance Prelude.Num a => Monoid (Product a)  +instance Prelude.Num a => Monoid (Sum a)  +instance Monoid (Endo a)  +instance Monoid a => Monoid (Dual a)  +-- instance Monoid b => Monoid (a -> b)  +instance (Monoid a, Monoid b) => Monoid (a, b)  +-- instance Monoid (Proxy * s)   +instance Monoid a => Monoid (Const a b)   +-- instance Typeable (* -> Constraint) Monoid  +instance (Monoid a, Monoid b, Monoid c) => Monoid (a, b, c)   +instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a, b, c, d)  +instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => Monoid (a, b, c, d, e)++data Dual a+data Endo a+data All+data Any+data Sum a+data Product a+data First a+data Last a+data Alt f a

+ environment/Ord.hs view

@@ -0,0 +1,54 @@+module Data.Ord where++++data Ordering++class Data.Eq.Eq a => Ord a where+  compare :: a -> a -> Ordering+  (<)  :: a -> a -> Data.Bool.Bool+  (>=) :: a -> a -> Data.Bool.Bool+  (>)  :: a -> a -> Data.Bool.Bool+  (<=) :: a -> a -> Data.Bool.Bool++comparing :: Ord a => (b -> a) -> b -> b -> Ordering++instance Ord a => Ord [a]+instance Prelude.Integral a => Ord (Ratio a)+-- instance Ord p => Ord (Par1 p)+instance Ord a => Ord (Data.Maybe.Maybe a)+instance Ord a => Ord (Down a)+instance Ord a => Ord (Last a)+instance Ord a => Ord (First a)+instance Ord a => Ord (Product a)+instance Ord a => Ord (Sum a)+instance Ord a => Ord (Dual a)+instance Ord a => Ord (ZipList a)+instance (Ord a, Ord b) => Ord (Data.Either.Either a b)+-- instance Ord (f p) => Ord (Rec1 f p)+instance (Ord a, Ord b) => Ord (a, b)+-- instance Ord c => Ord (K1 i c p)+-- instance (Ord (f p), Ord (g p)) => Ord ((:+:) f g p)+-- instance (Ord (f p), Ord (g p)) => Ord ((:*:) f g p)+-- instance Ord (f (g p)) => Ord ((:.:) f g p)+instance (Ord a, Ord b, Ord c) => Ord (a, b, c)+-- instance Ord (f p) => Ord (M1 i c f p)+instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d)+instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) => Ord (a, b, c, d, e, f)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) => Ord (a, b, c, d, e, f, g)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h) => Ord (a, b, c, d, e, f, g, h)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i) => Ord (a, b, c, d, e, f, g, h, i)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j) => Ord (a, b, c, d, e, f, g, h, i, j)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k) => Ord (a, b, c, d, e, f, g, h, i, j, k)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l) => Ord (a, b, c, d, e, f, g, h, i, j, k, l)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)++data Down a++instance Data.Eq.Eq a => Data.Eq.Eq (Down a)+instance Data.Ord.Ord a => Data.Ord.Ord (Down a)+instance Text.Read.Read a => Text.Read.Read (Down a)+instance Text.Show.Show a => Text.Show.Show (Down a)

+ environment/Prelude.hs view

@@ -0,0 +1,119 @@+module Prelude where++++data Float+data Double+data Integer+data Ordering+++++class (Text.Show.Show a, Data.Eq.Eq a) => Num a where+  fromInteger :: Integer -> a++class (Num a, Data.Ord.Ord a) => Real a where+  toRational :: a -> Rational++class Num a => Fractional a where+  fromRational :: Data.Ratio.Rational -> a+  -- omit (/) and recip++class Enum a where+  toEnum :: Data.Int.Int -> a+  fromEnum :: a -> Data.Int.Int+  enumFrom :: a -> [a]+  enumFromThen :: a -> a -> [a]+  enumFromTo :: a -> a -> [a]+  enumFromToThenTo :: a -> a -> a -> [a] -- all these methods might be bad for+                                         -- inference purposes+  -- omit succ, pred++class (Real a, Enum a) => Integral a where+  toInteger :: a -> Integer+  -- omit all other stuff++class (Real a, Fractional a) => RealFrac a where+  truncate :: Integral b => a -> b+  round    :: Integral b => a -> b+  ceiling  :: Integral b => a -> b+  floor    :: Integral b => a -> b+  -- omit properFraction++class Fractional a => Floating a where+  -- omit everything :D++class (RealFrac a, Floating a) => RealFloat a where+  -- omit everything.. this stuff is too obscure; i think we are better of+  -- in the general case without it.++class Bounded a where+  minBound, maxBound :: a -- fun for inference: you get an a for free!+  -- best idea probably to not declare any instances for this type class;+  -- otherwise, this will tank the inference performance.++fromIntegral :: (Integral a, Num b) => a -> b+realToFrac :: (Real a, Fractional b) => a -> b++instance Integral a => Num (Ratio a)+instance Num a => Num (Product a)+instance Num a => Num (Sum a)+instance RealFloat a => Num (Complex a)+instance HasResolution a => Num (Fixed a)++instance Integral a => Real (Ratio a)+instance HasResolution a => Real (Fixed a)++instance Integral a => RealFrac (Ratio a)+instance HasResolution a => RealFrac (Fixed a)++instance Integral a => Fractional (Ratio a)+instance RealFloat a => Fractional (Complex a)+instance HasResolution a => Fractional (Fixed a)++instance RealFloat a => Floating (Complex a)++instance Data.Eq.Eq Float+instance Floating Float+instance Data.Data.Data Float+instance Data.Ord.Ord Float+instance Text.Read.Read Float+instance RealFloat Float+instance GHC.Generics.Generic Float+instance Foreign.Storable.Storable Float+instance Text.Printf.PrintfArg Float++instance Data.Eq.Eq Double+instance Floating Double+instance Data.Data.Data Double+instance Data.Ord.Ord Double+instance Text.Read.Read Double+instance RealFloat Double+instance GHC.Generics.Generic Double+instance Foreign.Storable.Storable Double+instance Text.Printf.PrintfArg Double++instance Enum Integer+instance Data.Eq.Eq Integer+instance Integral Integer+instance Data.Data.Data Integer+instance Num Integer+instance Data.Ord.Ord Integer+instance Text.Read.Read Integer+instance Real Integer+instance Text.Show.Show Integer+instance Data.Ix.Ix Integer+instance Data.Bits.Bits Integer+instance Text.Printf.PrintfArg Integer++instance Bounded Ordering+instance Enum Ordering+instance Data.Eq.Eq Ordering+instance Data.Data.Data Ordering+instance Data.Ord.Ord Ordering+instance Text.Read.Read Ordering+instance Text.Show.Show Ordering+instance Data.Ix.Ix Ordering+instance GHC.Generics.Generic Ordering+instance Data.Monoid.Monoid Ordering

+ environment/Printf.hs view

@@ -0,0 +1,7 @@+module Text.Printf where++++class PrintfArg a where+class PrintfType t where+class HPrintfType t where

+ environment/Proxy.hs view

@@ -0,0 +1,22 @@+module Data.Proxy where++++data Proxy t = Proxy++-- instance Monad (Proxy *)+-- instance Functor (Proxy *)+-- instance Applicative (Proxy *)+-- instance Foldable (Proxy *)+-- instance Traversable (Proxy *)+-- instance Bounded (Proxy k s)+-- instance Enum (Proxy k s)+-- instance Data.Eq.Eq (Proxy k s)+-- instance Data.Data.Data t => Data.Data.Data (Proxy * t)+-- instance Data.Ord.Ord (Proxy k s)+-- instance Text.Read.Read (Proxy k s)+-- instance Show (Proxy k s)+-- instance Ix (Proxy k s)+-- instance GHC.Generics.Generic (Proxy * t)+-- instance Data.Monoid.Monoid (Proxy k s)+-- instance type Rep (Proxy k t)

+ environment/Ratio.hs view

@@ -0,0 +1,21 @@+module Data.Ratio where++++data Ratio a++instance Prelude.Integral a => Prelude.Enum (Ratio a)+instance Data.Data.Data.Eq.Eq a => Data.Data.Data.Eq.Eq (Ratio a)+instance Prelude.Integral a => Prelude.Fractional (Ratio a)+instance (Data.Data.Data a, Prelude.Integral a) => Data.Data.Data (Ratio a)+instance Prelude.Integral a => Prelude.Num (Ratio a)+instance Prelude.Integral a => Data.Data.Data.Ord.Ord (Ratio a)+instance (Prelude.Integral a, Text.Read.Read a) => Text.Read.Read (Ratio a)+instance Prelude.Integral a => Prelude.Real (Ratio a)+instance Prelude.Integral a => Prelude.RealFrac (Ratio a)+instance (Prelude.Integral a, Text.Show.Show a) => Text.Show.Show (Ratio a)+instance (Foreign.Storable.Storable a, Prelude.Integral a) => Foreign.Storable.Storable (Ratio a)++type Rational = Ratio Prelude.Integer++(%) :: Prelude.Integral a => a -> a -> Ratio a

+ environment/Read.hs view

@@ -0,0 +1,16 @@+module Text.Read where++++data ReadS+data Lexeme++instance Data.Eq.Eq Lexeme+instance Read Lexeme+instance Text.Show.Show Lexeme++class Read a where++readEither :: Read a => Data.String.String -> Data.Either.Either Data.String.String a ++readMaybe :: Read a => Data.String.String -> Data.Maybe.Maybe a

+ environment/Show.hs view

@@ -0,0 +1,46 @@+module Text.Show where++++data ShowS++class Show a where+  showsPrec :: Data.Int.Int -> a -> ShowS+  show :: a -> Data.String.String+  showList :: [a] -> ShowS++instance Show a => Show [a]   +instance (Prelude.Integral a, Show a) => Show (Data.Ratio.Ratio a)   +-- instance Show p => Show (Par1 p)+instance Show a => Show (Data.Maybe.Maybe a)+instance Show a => Show (Data.Monoid.Down a)+instance Show a => Show (Data.Monoid.Last a)+instance Show a => Show (Data.Monoid.First a)+instance Show a => Show (Data.Monoid.Product a)+instance Show a => Show (Data.Monoid.Sum a)+instance Show a => Show (Data.Monoid.Dual a)+instance Show a => Show (Control.Applicative.ZipList a)+-- instance Show a => Show (Complex a)+-- instance HasResolution a => Show (Fixed a)+-- instance Show (a -> b)+instance (Show a, Show b) => Show (Data.Either.Either a b)+-- instance Show (f p) => Show (Rec1 f p)+instance (Show a, Show b) => Show (a, b)+-- instance Show c => Show (K1 i c p)+-- instance (Show (f p), Show (g p)) => Show ((:+:) f g p)+-- instance (Show (f p), Show (g p)) => Show ((:*:) f g p)+-- instance Show (f (g p)) => Show ((:.:) f g p)+instance (Show a, Show b, Show c) => Show (a, b, c)+-- instance Show (f p) => Show (M1 i c f p)+instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d)+instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e)+instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a, b, c, d, e, f)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g) => Show (a, b, c, d, e, f, g)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h) => Show (a, b, c, d, e, f, g, h)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i) => Show (a, b, c, d, e, f, g, h, i)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j) => Show (a, b, c, d, e, f, g, h, i, j)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k) => Show (a, b, c, d, e, f, g, h, i, j, k)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l) => Show (a, b, c, d, e, f, g, h, i, j, k, l)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m) => Show (a, b, c, d, e, f, g, h, i, j, k, l, m)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m, Show n) => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m, Show n, Show o) => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)

+ environment/State.hs view

@@ -0,0 +1,22 @@+module Control.Monad.State where++++newtype State s a = State (s -> (a, s))+newtype StateT s m a = StateT (s -> m (a, s))++state :: (Control.Monad.Monad m)+      => (s -> (a, s))  -- ^pure state transformer+      -> StateT s m a   -- ^equivalent state-passing computation++get :: Control.Monad.Monad m => StateT s m s +put :: Control.Monad.Monad m => s -> StateT s m () ++instance Control.Monad.MonadTrans (StateT s)+instance Control.Monad.Monad m => Control.Monad.Monad (StateT s m)+instance Data.Functor.Functor m => Data.Functor.Functor (StateT s m)+instance Control.Monad.MonadFix m => MonadFix (StateT s m)+instance (Data.Functor.Functor m, Control.Monad.Monad m) => Control.Applicative.Applicative (StateT s m)+instance (Data.Functor.Functor m, Control.Monad.MonadPlus m) => Control.Applicative.Alternative (StateT s m)+instance Control.Monad.MonadPlus m => Control.Monad.MonadPlus (StateT s m)+instance Control.Monad.MonadIO m => MonadIO (StateT s m)

+ environment/Storable.hs view

@@ -0,0 +1,12 @@+module Foreign.Storable where++++class Storable a where++instance (Storable a, Prelude.Integral a) => Storable (Data.Ratio.Ratio a)+-- instance Storable (StablePtr a)+-- instance Storable (Ptr a)+-- instance Storable (FunPtr a)+-- instance Storable a => Storable (Complex a)+

+ environment/String.hs view

@@ -0,0 +1,6 @@+module Data.String where++type String = [Data.Char.Char]++-- class IsString a where+--   fromString :: String -> a

+ environment/SystemIO.hs view

@@ -0,0 +1,11 @@+module System.IO where++++data IO a++instance Data.Functor.Functor IO+instance Control.Applicative.Applicative IO+instance Control.Monad.Monad IO++type FilePath = Data.String.String

+ environment/Text.hs view

@@ -0,0 +1,20 @@+module Data.Text where++++data Text++pack :: Data.String.String -> Text+unpack :: Text -> Data.String.String++++-- instance IsList Text+instance Data.Eq.Eq Text+instance Data.Data.Data Text+instance Data.Ord.Ord Text+instance Text.Read.Read Text+instance Text.Show.Show Text+-- instance IsString Text+instance Data.Monoid.Monoid Text+-- instance Binary Text

+ environment/Traversable.hs view

@@ -0,0 +1,17 @@+module Data.Traversable where++++class (Data.Functor.Functor t, Data.Foldable.Foldable t) => Traversable t where+  traverse :: Control.Applicative.Applicative f => (a -> f b) -> t a -> f (t b)+  sequenceA :: Control.Applicative.Applicative f => t (f a) -> f (t a)+  -- mapM :: Control.Monad.Monad m => (a -> m b) -> t a -> m (t b)+  -- sequence :: Control.Monad.Monad m => t (m a) -> m (t a)++instance Traversable []+instance Traversable Data.Maybe.Maybe+instance Traversable Identity+-- instance Traversable (Data.Either.Either a)  -- cause "unused" problems+-- instance Traversable ((,) a)     -- cause "unused" problems+-- instance Traversable (Proxy *)+instance Traversable (Const m)

+ environment/Typeable.hs view

@@ -0,0 +1,22 @@+module Data.Typeable where++++data TypeRep++instance Data.Eq.Eq TypeRep+instance Data.Ord.Ord TypeRep+instance Text.Show.Show TypeRep++class Typeable a where++typeOf  :: forall a. Typeable a => a -> TypeRep+typeOf1 :: forall t a. Typeable t => t a -> TypeRep+typeOf2 :: forall t a b. Typeable t => t a b -> TypeRep+typeOf3 :: forall t a b c. Typeable t => t a b c -> TypeRep+typeOf4 :: forall t a b c d. Typeable t => t a b c d -> TypeRep+typeOf5 :: forall t a b c d e. Typeable t => t a b c d e -> TypeRep+typeOf6 :: forall t a b c d e f. Typeable t => t a b c d e f -> TypeRep+typeOf7 :: forall t a b c d e f g. Typeable t => t a b c d e f g -> TypeRep++cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b

+ environment/Void.hs view

@@ -0,0 +1,23 @@+module Data.Void where++++data Void++instance Data.Eq.Eq Void  +instance Data.Data.Data Void  +instance Data.Ord.Ord Void   +instance Text.Read.Read Void +instance Text.Show.Show Void  +instance Data.Ix.Ix Void  +instance GHC.Generics.Generic Void   +-- instance Exception Void   +-- instance Hashable Void  +-- instance Semigroup Void   +-- instance Typeable * Void  ++absurd :: Void -> a++vacuous :: Functor f => f Void -> f a++type Not x = x -> Void

+ environment/Word.hs view

@@ -0,0 +1,90 @@+module Data.Word where++++data Word+data Word8+data Word16+data Word32+data Word64+++instance Prelude.Bounded Word+instance Prelude.Enum Word+instance Data.Eq.Eq Word+instance Prelude.Integral Word+instance Data.Data.Data Word+instance Prelude.Num Word+instance Data.Ord.Ord Word+instance Text.Read.Read Word+instance Prelude.Real Word+instance Text.Show.Show Word+instance Data.Ix.Ix Word+instance Data.Bits.FiniteBits Word+instance Data.Bits.Bits Word+instance Foreign.Storable.Storable Word+instance Text.Printf.PrintfArg Word++instance Prelude.Bounded Word8+instance Prelude.Enum Word8+instance Data.Eq.Eq Word8+instance Prelude.Integral Word8+instance Data.Data.Data Word8+instance Prelude.Num Word8+instance Data.Ord.Ord Word8+instance Text.Read.Read Word8+instance Prelude.Real Word8+instance Text.Show.Show Word8+instance Data.Ix.Ix Word8+instance Data.Bits.FiniteBits Word8+instance Data.Bits.Bits Word8+instance Foreign.Storable.Storable Word8+instance Text.Printf.PrintfArg Word8++instance Prelude.Bounded Word16+instance Prelude.Enum Word16+instance Data.Eq.Eq Word16+instance Prelude.Integral Word16+instance Data.Data.Data Word16+instance Prelude.Num Word16+instance Data.Ord.Ord Word16+instance Text.Read.Read Word16+instance Prelude.Real Word16+instance Text.Show.Show Word16+instance Data.Ix.Ix Word16+instance Data.Bits.FiniteBits Word16+instance Data.Bits.Bits Word16+instance Foreign.Storable.Storable Word16+instance Text.Printf.PrintfArg Word16++instance Prelude.Bounded Word32+instance Prelude.Enum Word32+instance Data.Eq.Eq Word32+instance Prelude.Integral Word32+instance Data.Data.Data Word32+instance Prelude.Num Word32+instance Data.Ord.Ord Word32+instance Text.Read.Read Word32+instance Prelude.Real Word32+instance Text.Show.Show Word32+instance Data.Ix.Ix Word32+instance Data.Bits.FiniteBits Word32+instance Data.Bits.Bits Word32+instance Foreign.Storable.Storable Word32+instance Text.Printf.PrintfArg Word32++instance Prelude.Bounded Word64+instance Prelude.Enum Word64+instance Data.Eq.Eq Word64+instance Prelude.Integral Word64+instance Data.Data.Data Word64+instance Prelude.Num Word64+instance Data.Ord.Ord Word64+instance Text.Read.Read Word64+instance Prelude.Real Word64+instance Text.Show.Show Word64+instance Data.Ix.Ix Word64+instance Data.Bits.FiniteBits Word64+instance Data.Bits.Bits Word64+instance Foreign.Storable.Storable Word64+instance Text.Printf.PrintfArg Word64

+ environment/all.ratings view

@@ -0,0 +1,112 @@+Data.Functor.fmap         -2.1+Control.Applicative.pure  1.0+Control.Applicative.(<*>) 0.3+Text.Show.show            3.0+Data.Eq.(==)              4.0+Prelude.fromInteger       16.0+Prelude.toRational        16.0+Prelude.toInteger         16.0+Prelude.fromRational      16.0+Prelude.truncate          16.0+Prelude.round             16.0+Prelude.ceiling           16.0+Prelude.floor             16.0+Data.Either.Left          10.0+Data.Either.Right         999.0+Data.Maybe.Just           999.0+Data.Maybe.Nothing        6.0+()                        9.9+(:)                       5.0++Prelude.minBound          16.0+Prelude.maxBound          16.0+Prelude.toEnum            50.0+Data.Bool.(&&)            12.0+Data.Bool.(||)            12.0+Prelude.enumFrom          15.0+Prelude.fromEnum          15.0+Prelude.enumFromTo        15.0+Prelude.enumFromThen      15.0+Prelude.enumFromToThenTo  10.0+Data.Foldable.asum        8.0+Control.Monad.msum        15.0+Text.Show.showsPrec       30.0+Data.Ord.(<)              20.0+Data.Ord.(<=)             20.0+Data.Ord.(>)              20.0+Data.Ord.(>=)             20.0+(,)                       5.0+(,,)                      5.0+(,,,)                     4.0+(,,,,)                    3.0+(,,,,,)                   2.0++Control.Monad.mfilter     3.0+Prelude.realToFrac        20.0+Prelude.fromIntegral      20.0++Data.Maybe.maybe           6.0+Data.Maybe.fromMaybe       6.0+Data.Maybe.catMaybes       6.0+Data.Maybe.mapMaybe        6.0+Data.Maybe.maybeToList     6.0+Data.Map.lookup           -2.0++Control.Monad.(>>=)       -4.0+Control.Monad.(>>)        10.0++Data.Monoid.mempty        20.0+Data.Monoid.mappend       5.0+Data.Monoid.mconcat       5.0++Control.Applicative.(<|>)     20.0++Control.Monad.Trans.Cont.Cont 5.0++Data.Traversable.traverse     -2.0+Data.Traversable.sequenceA    -2.0++Data.Foldable.fold            7.5+Data.Foldable.foldMap         7.5+Data.Foldable.foldr           7.5+Data.Foldable.foldl           7.5+++Control.Monad.Trans.Either.runEitherT -3.5+Control.Monad.State.State 3.0+Control.Monad.State.get          10.0+Control.Monad.State.put          10.0+Control.Monad.State.state        10.0+Control.Monad.join               0.0++Data.Void.vacuous 50.0+Data.Void.absurd  12.0++Data.Bool.bool 20.0++Text.Read.readMaybe        10.0+Text.Read.readEither       10.0+Data.Typeable.cast         20.0+Data.Complex.imagPart      10.0+Data.Complex.realPart      10.0+Data.Typeable.typeOf       4.0+Control.Arrow.zeroArrow    20.0+Control.Category.id        20.0+Data.Data.dataTypeOf       10.0+Data.Data.toConstr         5.0+Data.Data.dataTypeConstrs  5.0+Data.Ord.compare           4.0+Data.Char.ord              3.0+Data.Char.chr              3.0++Data.Data.gmapQi           3.0++Control.Comonad.extract    9.0++Data.Text.pack             6.0+Data.Text.unpack           6.0++Data.Proxy.Proxy           7.0++Data.Bool.True             3.0+Data.Bool.False            3.0

+ exference.cabal view

@@ -0,0 +1,245 @@+Name:          exference+Version:       1.6.0.0+Cabal-Version: >= 1.8+Build-Type:    Simple+license:       BSD3+license-file:  LICENSE+Maintainer:    Lennart Spitzner <lsp@informatik.uni-kiel.de>+Author:        Lennart Spitzner+Homepage:      https://github.com/lspitzner/exference+Bug-reports:   https://github.com/lspitzner/exference/issues+Stability:     stable+Category:      Language+Synopsis:      Tool to search/generate (haskell) expressions with a given type+Description:+  Type inference takes an expression and tells you its type. This process+  can be inversed: We recursively create random expression trees while checking+  that they -so far- match a given input type. At each step we do the backwards+  step of the inference algorithm step. If you are lucky, this search+  yields one or more expressions.++  Djinn is a similar tool that guarantees to always terminate. But the+  cost of that property is that Djinn does not properly handle polymorphic+  queries - and those are the interesting ones, really :)++  Exference supports type classes, handles undeclared types well+  (Foo -> Foo yields id for unknown Foo), does _not_ check kinds,+  can pattern-match on newtypes, supports RankNTypes.++  Exference reads an environment of function types, data types, type classes+  and instances. The user can add to this environment, but keep in mind that+  each addition enlarges the search space.++data-files:+  environment/all.ratings+  environment/Applicative.hs+  environment/Arrow.hs+  environment/Bits.hs+  environment/Bool.hs+  environment/Category.hs+  environment/Char.hs+  environment/Comonad.hs+  environment/Complex.hs+  environment/Cont.hs+  environment/ControlMonadIOClass.hs+  environment/ControlMonadTransClass.hs+  environment/DataFunction.hs+  environment/Data.hs+  environment/Either.hs+  environment/EitherT.hs+  environment/Eq.hs+  environment/Foldable.hs+  environment/Functor.hs+  environment/Generics.hs+  environment/Int.hs+  environment/Ix.hs+  environment/List.hs+  environment/Map.hs+  environment/Maybe.hs+  environment/Monad.hs+  environment/MonadLoops.hs+  environment/Monoid.hs+  environment/Ord.hs+  environment/Prelude.hs+  environment/Printf.hs+  environment/Proxy.hs+  environment/Ratio.hs+  environment/Read.hs+  environment/Show.hs+  environment/State.hs+  environment/Storable.hs+  environment/String.hs+  environment/SystemIO.hs+  environment/Text.hs+  environment/Traversable.hs+  environment/Typeable.hs+  environment/Void.hs+  environment/Word.hs++source-repository head {+  type: git+  location: git@github.com:lspitzner/multistate.git+}++++flag build-executables+  description: build the executables, not just the library+  default: True+  manual: True++Flag linkNodes+  description: nodes keep a reference to the precessor node, allowing returning+               the path thad lead to a solution.+  default: False+  manual: True++Flag buildSearchTree+  description: use dirty hacks to create the search tree that can be observed+               afterwards. needs link-nodes flag.+  default: False+  manual: True++Flag exference-dev+  default: False+  manual: True++Library+  --ghc-options: -fllvm+  ghc-options: -O2+               -Wall+               -fno-warn-unused-imports+               -fno-warn-orphans+               -fno-spec-constr+  if impl(ghc > 8.0) {+    ghc-options: {+      -fno-warn-redundant-constraints+    }+  }+  if flag(exference-dev) {+    ghc-options: -Werror+                 -auto-all+                 -caf-all+  }+  If flag(linkNodes) || flag(buildSearchTree)+    cpp-options: -DLINK_NODES+  If flag(buildSearchTree)+    cpp-options: -DBUILD_SEARCH_TREE+  exposed-modules: Language.Haskell.Exference.Core+                   Language.Haskell.Exference.Core.Types+                   Language.Haskell.Exference.Core.TypeUtils+                   Language.Haskell.Exference.Core.ExferenceStats+                   Language.Haskell.Exference.Core.Expression+                   Language.Haskell.Exference.Core.ExpressionSimplify+                   Language.Haskell.Exference.Core.FunctionBinding+                   Language.Haskell.Exference.Core.SearchTree+  exposed-modules: Language.Haskell.Exference+                   Language.Haskell.Exference.SimpleDict+                   Language.Haskell.Exference.ExpressionToHaskellSrc+                   Language.Haskell.Exference.TypeFromHaskellSrc+                   Language.Haskell.Exference.TypeDeclsFromHaskellSrc+                   Language.Haskell.Exference.BindingsFromHaskellSrc+                   Language.Haskell.Exference.ClassEnvFromHaskellSrc+                   Language.Haskell.Exference.EnvironmentParser+                   Language.Haskell.Exference.FunctionDecl+                   Paths_exference+                   Flags_exference+  other-modules:   Language.Haskell.Exference.Core.Internal.Unify,+                   Language.Haskell.Exference.Core.Internal.ConstraintSolver,+                   Language.Haskell.Exference.Core.Internal.ExferenceNode,+                   Language.Haskell.Exference.Core.Internal.ExferenceNodeBuilder,+                   Language.Haskell.Exference.Core.Internal.Exference+  extensions:      NoMonomorphismRestriction+                   CPP+                   FlexibleContexts+                   ScopedTypeVariables+                   DeriveDataTypeable+                   TemplateHaskell+  hs-source-dirs: src+  Build-Depends:+    base                 >=4.7.0.2 && <5,+    base-orphans         >=0.5.1   && <0.6,+    containers           >=0.5.0.0 && <0.6,+    pretty               >=1.1     && <1.2,+    deepseq              >=1.3.0.1 && <1.5,+    deepseq-generics     >=0.1.1.2 && < 0.3,+    unordered-containers >=0.2.5   && < 0.3,+    hashable             >=1.2.4.0 && <1.3,+    pqueue               >=1.3.1   && < 1.4,+    mmorph               >=1.0.4   && < 1.1,+    transformers         >=0.3     && <0.6,+    mtl                  >=2.1     && <2.3,+    vector               >=0.11    && <0.13.0.0,+    either               >=4.4     && <4.5,+    haskell-src-exts     >=1.17.1  && <1.18,+    hood                 >=0.3     && <0.4,+    process              >=1.2.3.0 && <1.5,+    parsec               >=3.1.11  && <3.2,+    directory            >=1.2     && <1.3,+    bifunctors           >=5.4.1   && <5.5,+    safe                 >=0.3.10  && <0.4,+    lens                 >=4.12    && <4.15,+    split                >=0.2.3.1 && <0.3,+    multistate           >=0.6.2   && <0.8,++    template-haskell     >=2.8.0.0 && <2.12.0.0+    -- 2.11.0.0 causes problems on ghc-7.8.4.+++Executable exference+  if flag(build-executables) {+    buildable: True+    build-depends:+      exference,+      base >=3 && <5,+      containers,+      transformers,+      mtl,+      haskell-src-exts,+      data-pprint >= 0.2.4,+      deepseq,+      hood,+      process,+      either,+      multistate >= 0.6.2+  } else {+    buildable: False+  }+  other-modules: Main+                 MainConfig+                 MainTest+  main-is: Main.hs+  hs-source-dirs: src-exference+  ghc-options: -rtsopts+               -O2+               -Wall+               -fno-warn-unused-imports+               -fno-warn-orphans+               -threaded+               -fno-spec-constr+               -- -fllvm+  if impl(ghc > 8.0) {+    ghc-options: {+      -fno-warn-redundant-constraints+    }+  }+  if flag(exference-dev) {+    ghc-options: -Werror+                 -auto-all+                 -caf-all+  }+  If flag(buildSearchTree) {+    ghc-options:+               -with-rtsopts "-H4G -M6G -N"+  } else {+    ghc-options:+               -with-rtsopts "-H2G -M4G -N"++  }+++  extensions: NoMonomorphismRestriction+              FlexibleContexts+              ScopedTypeVariables+              CPP+              TemplateHaskell

+ src-exference/Main.hs view

@@ -0,0 +1,385 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PatternGuards #-}++module Main+  ( main+  )+where++++import Language.Haskell.Exference.Core ( ExferenceChunkElement(..)+                                       , ExferenceHeuristicsConfig(..)+                                       , findExpressionsWithStats )+import Language.Haskell.Exference+import Language.Haskell.Exference.ExpressionToHaskellSrc+import Language.Haskell.Exference.BindingsFromHaskellSrc+import Language.Haskell.Exference.ClassEnvFromHaskellSrc+import Language.Haskell.Exference.TypeFromHaskellSrc+import Language.Haskell.Exference.TypeDeclsFromHaskellSrc+import Language.Haskell.Exference.Core.FunctionBinding+import Language.Haskell.Exference.EnvironmentParser++import Language.Haskell.Exference.SimpleDict+import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.Core.Expression+import Language.Haskell.Exference.Core.ExpressionSimplify+import Language.Haskell.Exference.Core.ExferenceStats+import Language.Haskell.Exference.Core.SearchTree++import Control.DeepSeq++import System.Process hiding ( env )++import Control.Applicative ( (<$>), (<*>) )+import Control.Arrow ( first, second, (***) )+import Control.Monad ( when, forM_, guard, forM, mplus, mzero )+import Data.List ( sortBy, find, intersect, intersperse, intercalate, nub )+import Data.Ord ( comparing )+import Text.Printf+import Data.Maybe ( listToMaybe, fromMaybe, maybeToList )+import Data.Either ( lefts, rights )+import Data.Functor.Identity ( runIdentity )+import Control.Monad.Writer.Strict+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntMap as IntMap++import Language.Haskell.Exts.Syntax ( Module(..), Decl(..), ModuleName(..) )+import Language.Haskell.Exts.Parser ( parseModuleWithMode+                                    , parseModule+                                    , ParseResult (..)+                                    , ParseMode (..)+                                    , defaultParseMode )+import Language.Haskell.Exts.Extension ( Language (..)+                                       , Extension (..)+                                       , KnownExtension (..) )+import Language.Haskell.Exts.Pretty++import Control.Monad.Trans.MultiRWS+import Control.Monad.Trans.Either++import Data.PPrint+import Data.Tree ( Tree(..) )+++import MainConfig+import MainTest++import Paths_exference+import qualified Flags_exference++import System.Environment ( getArgs )+import System.Console.GetOpt+import Data.Version ( showVersion )+import System.IO ( hSetBuffering, BufferMode(..), stdout, stderr )++import Debug.Hood.Observe++import Debug.Trace++++data Flag = Verbose Int+          | Version+          | Help+          | Tests+          | Examples+          | PrintEnv+          | EnvDir String+          | Input String+          | PrintAll+          | PrintTree -- TODO: more options to control core+          | EnvUsage -- TODO: option to specify dictionary to use+          | Serial+          | Parallel+          | Shortest+          | FirstSol+          | Best+          | Unused+          | PatternMatchMC+          | Qualification Int+          | Constraints+          | AllowFix+  deriving (Show, Eq)++options :: [OptDescr Flag]+options =+  [ Option []    ["version"]     (NoArg Version)       ""+  , Option []    ["help"]        (NoArg Help)          "prints basic program info"+  , Option ['t'] ["tests"]       (NoArg Tests)         "run the standard validity/performance tests"+  , Option ['x'] ["examples"]    (NoArg Examples)      "prints the first few results for the examples; useful for debugging"+  , Option ['p'] ["printenv"]    (NoArg PrintEnv)      "print the environment to be used for queries"+  , Option ['e'] ["envdir"]      (ReqArg EnvDir "PATH") "path to environment directory"+  , Option ['v'] ["verbose"]     (OptArg (Verbose . maybe 1 read) "INT") "verbosity"+  , Option ['i'] ["input"]       (ReqArg Input "HSTYPE") "the type for which to generate an expression"+  , Option ['a'] ["all"]         (NoArg PrintAll)      "print all solutions (up to search step limit)"+  , Option []    ["envUsage"]    (NoArg EnvUsage)      "print a list of functions that got inserted at some point (regardless if successful or not), and how often"+  , Option []    ["tree"]        (NoArg PrintTree)     "print tree of search space"+  , Option []    ["serial"]      (NoArg Serial)        "use the non-parallelized version of the algorithm (default)"+  , Option ['j'] ["parallel"]    (NoArg Parallel)      "use the parallelized version of the algorithm"+  , Option ['o'] ["short"]       (NoArg Shortest)      "prefer shorter solutions"+  , Option ['f'] ["first"]       (NoArg FirstSol)      "stop after finding the first solution"+  , Option []    ["fix"]         (NoArg AllowFix)      "allow the `fix` function in the environment"+  , Option ['b'] ["best"]        (NoArg Best)          "calculate all solutions, and print the best one"+  , Option ['u'] ["allowUnused"] (NoArg Unused)        "allow unused input variables"+  , Option ['c'] ["patternMatchMC"] (NoArg PatternMatchMC) "pattern match on multi-constructor data types (might lead to hang-ups at the moment)"+  , Option ['q'] ["fullqualification"] (NoArg $ Qualification 2) "fully qualify the identifiers in the output"+  , Option []    ["somequalification"] (NoArg $ Qualification 1) "fully qualify non-operator-identifiers in the output"+  , Option ['w'] ["allowConstraints"] (NoArg Constraints) "allow additional (unproven) constraints in solutions"+  ]++mainOpts :: [String] -> IO ([Flag], [String])+mainOpts argv =+  case getOpt Permute options argv of+    (o, n, []  )  | inputs <- [x | (Input x) <- o] ++ n+                  -> if null (intersect o [Version, Help, Tests, Examples, PrintEnv])+                     && null inputs+                    then return (Tests:o, inputs)+                    else return (o      , inputs)+    (_,  _, errs) -> ioError (userError (concat errs ++ fullUsageInfo))++fullUsageInfo :: String+fullUsageInfo = usageInfo header options+  where+    header = "Usage: exference [OPTION...]"++main :: IO ()+main = runO $ do+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering+  argv <- getArgs+  defaultEnvPath <- getDataFileName "environment"+  (flags, inputs) <- mainOpts argv+  let verbosity = sum $ [x | Verbose x <- flags ]+  let qualification = head $ [x | Qualification x <- flags] ++ [0]+  let+    printVersion = do+      putStrLn $ "exference version " ++ showVersion version+  if | [Version] == flags   -> printVersion+     | Help    `elem` flags -> putStrLn fullUsageInfo >> putStrLn "TODO"+     | otherwise -> runMultiRWSTNil_ $ do+        par <- case (Parallel `elem` flags, Serial `elem` flags) of+          (False,False) -> return False+          (True, False) -> return True+          (False,True ) -> return False+          (True, True ) ->+            error "--serial and --parallel are in conflict! aborting"+        when (Version `elem` flags || verbosity>0) $ lift printVersion+        -- ((eSignatures, StaticClassEnv clss insts), messages) <- runWriter <$> parseExternal testBaseInput'+        let envDir = fromMaybe defaultEnvPath $ listToMaybe [d | EnvDir d <- flags]+        when (verbosity>0) $ lift $ do+          putStrLn $ "[Environment]"+          putStrLn $ "reading environment from " ++ envDir+        ( (eSignatures+          , eDeconss+          , sEnv@(StaticClassEnv clss insts)+          , validNames+          , tdeclMap )+         ,messages :: [String] ) <- withMultiWriterAW $ environmentFromPath envDir+        let+          env = (eSignatures, eDeconss, sEnv)+        when (verbosity>0 && not (null messages)) $ lift $+          forM_ messages $ \m -> putStrLn $ "environment warning: " ++ m+        when (PrintEnv `elem` flags) $ lift $ do+          when (verbosity>0) $ putStrLn "[Environment]"+          mapM_ print $ M.elems tdeclMap+          mapM_ print $ clss+          mapM_ print $ [(i,x)| (i,xs) <- M.toList insts, x <- xs]+          mapM_ print $ eSignatures+          mapM_ print $ eDeconss+        when (Examples `elem` flags) $ do+          when (verbosity>0) $ lift $ putStrLn "[Examples]"+          printAndStuff testHeuristicsConfig env+        when (Tests `elem` flags) $ do+          when (verbosity>0) $ lift $ putStrLn "[Tests]"+          withMultiReader tdeclMap $ printCheckExpectedResults+                                       testHeuristicsConfig { heuristics_solutionLength = 0.0 }+                                       env+        case inputs of+          []    -> return () -- probably impossible..+          (x:_) -> do+            when (verbosity>0) $ lift $ putStrLn "[Custom Input]"+            eParsedType <- runEitherT $ parseType (sClassEnv_tclasses sEnv)+                                                  Nothing+                                                  validNames+                                                  tdeclMap+                                                  (haskellSrcExtsParseMode "inputtype")+                                                  x+            case eParsedType of+              Left err -> lift $ do+                putStrLn $ "could not parse input type: " ++ err+              Right (parsedType, tVarIndex) -> do+                let typeStr = showHsType tVarIndex parsedType+                when (verbosity>0) $ lift $ putStrLn $ "input type parsed as: " ++ typeStr+                let unresolvedIdents = findInvalidNames validNames parsedType+                when (not $ null unresolvedIdents) $ lift $ do+                  putStrLn $ "warning: unresolved idents in input: "+                           ++ intercalate ", " (nub $ show <$> unresolvedIdents)+                  putStrLn $ "(this may be harmless, but no instances will be connected to these.)"+                let hidden = if AllowFix `elem` flags then [] else ["fix", "forever", "iterateM_"]+                let filteredBindings = filterBindingsSimple hidden eSignatures+                let input = ExferenceInput+                      parsedType+                      filteredBindings+                      eDeconss+                      sEnv+                      (Unused `elem` flags)+                      (Constraints `elem` flags)+                      8192+                      (PatternMatchMC `elem` flags)+                      65536+                      (Just 8192)+                      (if Shortest `elem` flags then+                         testHeuristicsConfig+                       else+                         testHeuristicsConfig { heuristics_solutionLength = 0.0 })+                when (verbosity>0) $ lift $ do+                  putStrLn $ "full input:"+                  doc <- pprint input+                  print doc+                if+                  | PrintAll `elem` flags -> do+                      when (verbosity>0) $ lift $ putStrLn "[running findExpressions ..]"+                      let rs = findExpressions input+                      if null rs+                        then lift $ putStrLn "[no results]"+                        else forM_ rs+                          $ \(e, constrs, ExferenceStats n d m) -> do+                            let hsE = convert qualification $ simplifyExpression e+                            lift $ putStrLn $ prettyPrint hsE+                            when (not $ null constrs) $ do+                              let constrStrs = map (showHsConstraint tVarIndex)+                                             $ S.toList+                                             $ S.fromList+                                             $ constrs+                              lift $ putStrLn $ "but only with additional contraints: " ++ intercalate ", " constrStrs+                            lift $ putStrLn $ replicate 40 ' ' ++ "(depth " ++ show d+                                        ++ ", " ++ show n ++ " steps, " ++ show m ++ " max pqueue size)"+                  | PrintTree `elem` flags ->+                      if not Flags_exference.buildSearchTree+                        then lift $ putStrLn "exference-core was not compiled with flag \"buildSearchTree\""+                        else do+#if BUILD_SEARCH_TREE+                          when (verbosity>0) $ lift $ putStrLn "[running findExpressionsWithStats ..]"+                          let tree = chunkSearchTree $ last $ findExpressionsWithStats+                                   $ input {input_maxSteps = 8192}+                          let showf (total,processed,expression)+                                = ( printf "%d (+%d):" processed (total-processed)+                                  , showExpressionPure qNameIndex $ simplifyExpression expression+                                  )+                          let+                            helper :: String -> Tree (String, String) -> [String]+                            helper indent (Node (n,m) ts) =+                              (printf "%-50s %s" (indent ++ n) m)+                              : concatMap (helper ("  "++indent)) ts+                          (lift . putStrLn) `mapM_` helper "" (showf <$> filterSearchTreeProcessedN 64 tree)+#endif+                          return ()+                          -- putStrLn . showf `mapM_` draw+                          --   -- $ filterSearchTreeProcessedN 2+                          --   tree+                  | EnvUsage `elem` flags -> lift $ do+                      when (verbosity>0) $ putStrLn "[running findExpressionsWithStats ..]"+                      let stats = chunkBindingUsages $ last $ findExpressionsWithStats input+                          highest = take 8 $ sortBy (flip $ comparing snd) $ M.toList stats+                      putStrLn $ show $ highest+                  | otherwise -> do+                      r <- if+                        | FirstSol `elem` flags -> if par+                          then lift $ do+                            putStrLn $ "WARNING: parallel version not implemented for given flags, falling back to serial!"+                            when (verbosity>0) $ putStrLn "[running findOneExpression ..]"+                            return $ maybeToList $ findOneExpression input+                          else lift $ do+                            when (verbosity>0) $ putStrLn "[running findOneExpression ..]"+                            return $ maybeToList $ findOneExpression input+                        | Best `elem` flags -> if par+                          then lift $ do+                            putStrLn $ "WARNING: parallel version not implemented for given flags, falling back to serial!"+                            when (verbosity>0) $ putStrLn "[running findBestNExpressions ..]"+                            return $ findBestNExpressions 999 input+                          else lift $ do+                            when (verbosity>0) $ putStrLn "[running findBestNExpressions ..]"+                            return $ findBestNExpressions 999 input+                        | otherwise -> if par+                          then lift $ do+                            putStrLn $ "WARNING: parallel version not implemented for given flags, falling back to serial!"+                            when (verbosity>0) $ putStrLn "[running findFirstBestExpressionsLookaheadPreferNoConstraints ..]"+                            return $ findFirstBestExpressionsLookaheadPreferNoConstraints 256 input+                          else lift $ do+                            if Constraints `elem` flags+                              then do+                                when (verbosity>0) $ putStrLn "[running findFirstBestExpressionsLookahead ..]"+                                return $ findFirstBestExpressionsLookahead 256 input+                              else do+                                when (verbosity>0) $ putStrLn "[running findFirstBestExpressionsLookaheadPreferNoConstraints ..]"+                                return $ findFirstBestExpressionsLookaheadPreferNoConstraints 256 input {input_allowConstraints = True}+                      case r :: [ExferenceOutputElement] of+                        [] -> lift $ putStrLn "[no results]"+                        rs -> rs `forM_` \(e, constrs, ExferenceStats n d m) -> do+                            let hsE = convert qualification $ simplifyExpression e+                            lift $ putStrLn $ prettyPrint hsE+                            when (not $ null constrs) $ do+                              let constrStrs = map (showHsConstraint tVarIndex)+                                             $ S.toList+                                             $ S.fromList+                                             $ constrs+                              lift $ putStrLn $ "but only with additional contraints: " ++ intercalate ", " constrStrs+                            lift $ putStrLn $ replicate 40 ' ' ++ "(depth " ++ show d+                                       ++ ", " ++ show n ++ " steps, " ++ show m ++ " max pqueue size)"++        -- printChecks     testHeuristicsConfig env+        -- printStatistics testHeuristicsConfig env++        -- print $ compileDict testDictRatings $ eSignatures+        -- print $ parseConstrainedType defaultClassEnv $ "(Show a) => [a] -> String"+        -- print $ inflateHsConstraints a b+        {-+        let t :: HsType+            t = read "m a->( ( a->m b)->( m b))"+        print $ t+        -}++_pointfree :: String -> IO String+_pointfree s = (!!1) <$> lines <$> readProcess "pointfree" ["--verbose", s] ""++_pointful :: String -> IO String+_pointful s = (!!0) <$> lines <$> readProcess "pointful" [s] ""++_tryParse :: Bool -> String -> IO ()+_tryParse shouldBangPattern s = do+  content <- readFile $ "/home/lsp/asd/prog/haskell/exference/BaseContext/preprocessed/"++s++".hs"+  let exts1 = (if shouldBangPattern then (BangPatterns:) else id)+              [ UnboxedTuples+              , TypeOperators+              , MagicHash+              , NPlusKPatterns+              , ExplicitForAll+              , ExistentialQuantification+              , TypeFamilies+              , PolyKinds+              , DataKinds ]+      exts2 = map EnableExtension exts1+  case parseModuleWithMode (ParseMode (s++".hs")+                                      Haskell2010+                                      exts2+                                      False+                                      False+                                      Nothing+                                      False+                           )+                           content of+    f@(ParseFailed _ _) -> do+      print f+    ParseOk _modul -> do+      putStrLn s+      --mapM_ putStrLn $ map (either id show)+      --               $ getBindings defaultClassEnv mod+      --mapM_ putStrLn $ map (either id show)+      --               $ getDataConss mod+      --mapM_ putStrLn $ map (either id show)+      --               $ getClassMethods defaultClassEnv mod

+ src-exference/MainConfig.hs view

@@ -0,0 +1,111 @@+module MainConfig+  ( testDictRatings +  , testHeuristicsConfig+  , testBaseInput+  , testBaseInput'+  )+where++++import Language.Haskell.Exference.Core ( ExferenceHeuristicsConfig(..)+                                       )++import Language.Haskell.Exts.Extension ( Language (..)+                                       , Extension (..)+                                       , KnownExtension (..) )++import Language.Haskell.Exts.Parser ( ParseMode (..) )+++testDictRatings :: [(String, Float)]+testDictRatings =+  [ (,) "maybe"    0.0+  , (,) "either"   0.0+  , (,) "curry"    0.0+  , (,) "uncurry"  0.0+  --, (,) "compare"  0.0+  --, (,) "minBound" 0.0+  --, (,) "maxBound" 0.0+  , (,) "fmap"     0.0+  -- , (,) "pure"     0.0+  -- , (,) "(<*>)"    0.0+  , (,) "(>>=)"    0.0+  , (,) "mapM"     0.0+  , (,) "sequence" 0.0+  , (,) "foldl"    0.0+  , (,) "foldr"    0.0+  , (,) "concat"   0.0+  , (,) "zip"      0.0+  , (,) "zip3"     0.0+  , (,) "zipWith"  0.0+  , (,) "unzip"    0.0+  , (,) "unzip3"   0.0+  , (,) "repeat"   0.0+  , (,) "Just"     0.0+  --, (,) "(&&)"       0.0+  --, (,) "(||)"       0.0+  ]++testBaseInput :: [(Bool, String)]+testBaseInput = [ (,) True  "GHCEnum"+                , (,) True  "GHCReal"+                , (,) True  "GHCShow"+                , (,) False "ControlMonad"+                , (,) False "DataEither"+                , (,) False "DataList"+                , (,) False "DataMaybe"+                , (,) False "DataTuple"+                , (,) False "DataOrd"+                , (,) False "GHCArr"+                , (,) False "GHCBase"+                , (,) False "GHCFloat"+                , (,) False "GHCList"+                , (,) False "GHCNum"+                , (,) False "GHCST"+                , (,) False "SystemIOError"+                , (,) False "SystemIO"+                , (,) False "TextRead"+                ]++testBaseInput' :: [(ParseMode, String)]+testBaseInput' = map h testBaseInput+  where+    h (shouldBangPattern, s) =+      let exts1 = (if shouldBangPattern then (BangPatterns:) else id)+                  [ UnboxedTuples+                  , TypeOperators+                  , MagicHash+                  , NPlusKPatterns+                  , ExplicitForAll+                  , ExistentialQuantification+                  , TypeFamilies+                  , PolyKinds+                  , DataKinds ]+          exts2 = map EnableExtension exts1+          mode = ParseMode (s++".hs")+                           Haskell2010+                           exts2+                           False+                           False+                           Nothing+                           False+          fname = "./BaseContext/preprocessed/"++s++".hs"+      in (mode, fname)++testHeuristicsConfig :: ExferenceHeuristicsConfig+testHeuristicsConfig = ExferenceHeuristicsConfig+  { heuristics_goalVar               =  0.8 -- tested to .1+  , heuristics_goalCons              =  0.7 -- tested to .1+  , heuristics_goalArrow             =  4.3 -- tested to .1+  , heuristics_goalApp               =  1.9 -- tested to .1+  , heuristics_stepProvidedGood      =  0.22 -- tested to .1+  , heuristics_stepProvidedBad       =  5.0 -- tested to .1+  , heuristics_stepEnvGood           =  6.0 -- tested to .1+  , heuristics_stepEnvBad            = 22.0 -- can improve, but needs testcases+  , heuristics_tempUnusedVarPenalty  =  1.1 -- tested to .1+  , heuristics_tempMultiVarUsePenalty=  6.7 -- tested to .1+  , heuristics_functionGoalTransform =  0.1 -- tested to .1+  , heuristics_unusedVar             = 20.0+  , heuristics_solutionLength        =  0.0153+  }

+ src-exference/MainTest.hs view

@@ -0,0 +1,657 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonadComprehensions #-}++module MainTest+  ( printAndStuff+  , printCheckExpectedResults+  , printStatistics+  , printMaxUsage+#if BUILD_SEARCH_TREE+  , printSearchTree+#endif+  , filterBindingsSimple -- TODO: refactor/move this+  )+where++++import Language.Haskell.Exference.Core ( ExferenceHeuristicsConfig(..)+                                       , findExpressionsWithStats+                                       , ExferenceChunkElement(..)+                                       )+import Language.Haskell.Exference+import Language.Haskell.Exference.ExpressionToHaskellSrc+import Language.Haskell.Exference.BindingsFromHaskellSrc+import Language.Haskell.Exference.ClassEnvFromHaskellSrc+import Language.Haskell.Exference.TypeFromHaskellSrc+import Language.Haskell.Exference.TypeDeclsFromHaskellSrc+import Language.Haskell.Exference.Core.FunctionBinding++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.Core.Expression+import Language.Haskell.Exference.Core.ExpressionSimplify+import Language.Haskell.Exference.Core.ExferenceStats+import Language.Haskell.Exference.Core.SearchTree++import Control.DeepSeq++import Control.Applicative ( (<$>), (<*>) )+import Control.Arrow ( second, (***) )+import Control.Monad ( when, forM_, guard, forM, mplus, mzero )+import Data.Functor.Identity ( Identity, runIdentity )+import Data.List ( sortBy, find, intercalate, maximumBy )+import Data.Ord ( comparing )+import Text.Printf+import Data.Maybe ( listToMaybe, fromMaybe, maybeToList, catMaybes )+import Data.Either ( lefts, rights )+import Control.Monad.Writer.Strict+import qualified Data.Map as M+import qualified Data.IntMap as IntMap+import Data.Tree ( drawTree )+import Control.Monad.Trans.Maybe ( MaybeT (..) )+import Data.Foldable ( asum )++import Control.Monad.Trans.MultiRWS+import Data.HList.ContainsType++import Language.Haskell.Exts.Syntax ( Module(..), Decl(..), ModuleName(..) )+import Language.Haskell.Exts.Parser ( parseModuleWithMode+                                    , parseModule+                                    , ParseResult (..)+                                    , ParseMode (..) )+import Language.Haskell.Exts.Extension ( Language (..)+                                       , Extension (..)+                                       , KnownExtension (..) )++-- import Data.PPrint++-- import Debug.Hood.Observe+import Debug.Trace++++checkData :: [(String, Bool, Bool, String, [String], [String])]+checkData =+  [ (,,,,,) "showmap"    False False "(Text.Show.Show b) => (a -> b) -> [a] -> [String]"+                                     ["\\f1 -> Data.Functor.fmap (\\g -> Text.Show.show (f1 g))"+                                     ,"\\f1 -> Data.Functor.fmap (((.) Text.Show.show) f1)"+                                     ,"\\f1 -> (\\c -> ((Control.Monad.>>=) c) (\\g -> Control.Applicative.pure (Text.Show.show (f1 g))))"]+                                     []+  , (,,,,,) "ffbind"     False False "(a -> t -> b) -> (t -> a) -> (t -> b)"+                                     ["\\f1 -> (\\f2 -> (\\c -> (f1 (f2 c)) c))"]+                                     []+  , (,,,,,) "join"       False False "(Monad m) => m (m a) -> m a"+                                     ["\\a -> ((Control.Monad.>>=) a) (\\f -> f)"+                                     ,"\\a -> ((Control.Monad.>>=) a) id"+                                     ]+                                     ["join"]+  , (,,,,,) "fjoin"      False False "(t -> (t -> a)) -> t -> a"+                                     ["\\f1 -> (\\b -> (f1 b) b)"]+                                     []+  , (,,,,,) "zipThingy"  False False "[a] -> b -> [(a, b)]"+                                     ["\\as -> (\\b -> ((Data.Functor.fmap (\\g -> ((,) g) b)) as)"+                                     ,"\\as -> (\\b -> (Data.List.zip as) (Control.Applicative.pure b))"+                                     ,"\\as -> ((.) (Data.List.zip as)) Control.Applicative.pure"+                                     ]+                                     []+  , (,,,,,) "pmatch"     False True  "Data.Maybe.Maybe a -> a -> a"+                                     ["\\m1 -> (\\b -> ((Data.Maybe.maybe b) (\\h -> h)) m1)"+                                     ,"\\m1 -> (\\b -> case m1 of { Data.Maybe.Just d -> d; Data.Maybe.Nothing  -> b })"]+                                     []+  --, (,,,,,) "pmatch2"    False True  "Tuple2 (Either a b) c -> Tuple2 (Maybe (Tuple2 a c)) (Maybe (Tuple2 b c))"+  --                                  []+  --                                   []+  , (,,,,,) "stateRun"   True  False "Control.Monad.State.State a b -> a -> b"+                                     ["\\s1 -> (\\b -> let (Control.Monad.State.State f4) = s1 in let ((,) g h) = f4 b in g)"]+                                     []+  , (,,,,,) "fst"        True  False "(a, b) -> a"+                                     ["\\a -> let ((,) c d) = a in c"]+                                     []+  --, (,,,,,) "ffst"       True False  "(a -> Tuple b c) -> a -> b"+  , (,,,,,) "snd"        True  False "(a, b) -> b"+                                     ["\\a -> let ((,) c d) = a in d"]+                                     []+  , (,,,,,) "quad"       False False "a -> ((a, a), (a, a))"+                                     ["\\a -> ((,) (((,) a) a)) (((,) a) a)"]+                                     []+  -- , (,,,,,) "fswap"     False False  "(a -> Tuple b c) -> a -> Tuple c b"+  , (,,,,,) "liftBlub"   False False "Monad m => m a -> m b -> (a -> b -> m c) -> m c"+                                     ["\\a -> (\\b -> (\\f3 -> ((Control.Monad.>>=) a) (\\g -> ((Control.Monad.>>=) b) (f3 g))))"+                                     ,"\\a -> (\\b -> (\\f3 -> ((Control.Monad.>>=) b) (\\g -> ((Control.Monad.>>=) a) (\\k -> (f3 k) g))))"]+                                     []+  , (,,,,,) "stateBind"  False False "Control.Monad.State.State s a -> (a -> Control.Monad.State.State s b) -> Control.Monad.State.State s b"+                                     ["\\s1 -> (\\f2 -> let (Control.Monad.State.State f4) = s1 in Control.Monad.State.State (\\f -> let ((,) j k) = f4 f in let (Control.Monad.State.State f14) = f2 j in f14 k))"]+                                     []+  , (,,,,,) "dbMaybe"    False False "Data.Maybe.Maybe a -> Data.Maybe.Maybe (a, a)"+                                     ["Data.Functor.fmap (\\e -> ((,) e) e)"+                                     ,"\\b -> ((Control.Applicative.liftA2 (\\g -> (\\h -> ((,) h) g))) b) b"+                                     ,"\\b -> ((Control.Monad.>>=) b) (\\f -> Control.Applicative.pure (((,) f) f))"]+                                     []+  , (,,,,,) "tupleShow"  False False "(Text.Show.Show a, Text.Show.Show b) => (a, b) -> String"+                                     ["Text.Show.show"+                                     ,"\\a -> let ((,) c d) = a in Text.Show.show (((,) c) d)"]+                                     []+  , (,,,,,) "FloatToInt" False False "Float -> Int"+                                     [ "Prelude.round"+                                     , "Prelude.floor"+                                     , "Prelude.truncate"+                                     , "Prelude.ceiling"+                                     ]+                                     []+  , (,,,,,) "FloatToIntL" False False "[Float] -> [Int]"+                                     ["Data.Functor.fmap Prelude.round"+                                     ,"Data.Functor.fmap Prelude.floor"+                                     ,"Data.Functor.fmap Prelude.ceiling"+                                     ,"Data.Functor.fmap Prelude.truncate"+                                     ,"\\b -> ((>>=) b) (\\f -> Control.Applicative.pure (Prelude.truncate f))" -- this is kind of ugly+                                     ,"((.) (Data.Functor.fmap Data.Char.ord)) Text.Show.show" -- this is not the solution we really want .. :/+                                     ]+                                     []+  , (,,,,,) "longApp"    False False "a -> b -> c -> (a -> b -> d) -> (a -> c -> e) -> (b -> c -> f) -> (d -> e -> f -> g) -> g"+                                     ["\\a -> (\\b -> (\\c -> (\\f4 -> (\\f5 -> (\\f6 -> (\\f7 -> ((f7 ((f4 a) b)) ((f5 a) c)) ((f6 b) c)))))))"]+                                     []+  , (,,,,,) "liftSBlub"  False False "(Monad m, Monad n) => ([a] -> b -> c) -> m [n a] -> m (n b) -> m (n c)"+                                     ["\\f1 -> Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) (Data.Traversable.sequenceA i)) (\\o -> ((Control.Monad.>>=) j) (\\s -> Control.Applicative.pure ((f1 o) s)))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) (Data.Traversable.sequenceA j)) (\\o -> ((Control.Monad.>>=) i) (\\s -> Control.Applicative.pure ((f1 o) s)))))) c) b))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> (Data.Functor.fmap (\\k -> ((Control.Monad.>>=) (Data.Traversable.sequenceA gs)) (\\p -> (Data.Functor.fmap (f1 p)) k))) c)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) (Data.Traversable.sequenceA ks)) (\\p -> (Data.Functor.fmap (f1 p)) g))) b)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) g) (\\p -> (Data.Functor.fmap (\\t -> (f1 t) p)) ((Data.Traversable.mapM (\\z -> z)) ks)))) b)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) g) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) ks)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\k -> Control.Applicative.pure (((Control.Monad.>>=) k) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) gs)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\k -> Control.Applicative.pure (((Control.Monad.>>=) k) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence gs)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) g) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence ks)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) ((Data.Traversable.mapM (\\t -> t)) ks)) (\\r -> (Data.Functor.fmap (f1 r)) g))) b)))"]+                                     []+  , (,,,,,) "liftSBlubS" False False "Monad m => ([a] -> b -> c) -> m [Data.Maybe.Maybe a] -> m (Data.Maybe.Maybe b) -> m (Data.Maybe.Maybe c)"+                                     ["\\f1 -> Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) j) (\\n -> (Data.Functor.fmap (\\r -> (f1 r) n)) (Data.Traversable.sequenceA i))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) i) (\\n -> (Data.Functor.fmap (\\r -> (f1 r) n)) (Data.Traversable.sequenceA j))))) c) b))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> (Data.Functor.fmap (\\m11 -> ((Control.Monad.>>=) (Data.Traversable.sequenceA gs)) (\\p -> (Data.Functor.fmap (f1 p)) m11))) c)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) (Data.Traversable.sequenceA ks)) (\\p -> (Data.Functor.fmap (f1 p)) m7))) b)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> (Data.Functor.fmap (\\m11 -> ((Control.Monad.>>=) (Prelude.sequence gs)) (\\p -> (Data.Functor.fmap (f1 p)) m11))) c)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) m7) (\\p -> (Data.Functor.fmap (\\t -> (f1 t) p)) ((Data.Traversable.mapM (\\z -> z)) ks)))) b)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) m7) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) ks)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\m11 -> Control.Applicative.pure (((Control.Monad.>>=) m11) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) gs)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\m11 -> Control.Applicative.pure (((Control.Monad.>>=) m11) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence gs)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) m7) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence ks)))))))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) ((Data.Traversable.mapM (\\t -> t)) ks)) (\\r -> (Data.Functor.fmap (f1 r)) m7))) b)))"+                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (Data.Traversable.mapM (\\ks -> (Data.Functor.fmap (\\p -> (f1 (fold ((Data.Traversable.mapM (\\w -> w)) p))) ks)) b))))"]+                                     []+  , (,,,,,) "joinBlub"   False False "Monad m => [Decl] -> (Decl -> m [FunctionBinding]) -> m [FunctionBinding]"+                                     ["\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.traverse f2) as)) (\\i -> Control.Applicative.pure (Control.Monad.join i)))"+                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.traverse f2) as)) (((.) Control.Applicative.pure) Control.Monad.join))"+                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\i -> Control.Applicative.pure (((Control.Monad.>>=) i) (\\p -> p))))"+                                     ,"\\as -> (\\f2 -> (Data.Functor.fmap (\\g -> ((Control.Monad.>>=) g) (\\k -> k))) ((Data.Traversable.mapM f2) as))"+                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\l -> Control.Applicative.pure (((Control.Monad.>>=) l) (\\p -> p))))"+                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\l -> Control.Applicative.pure (concat l)))"+                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\i -> (Data.Traversable.mapM (\\p -> p)) (((Control.Monad.>>=) i) (Data.Functor.fmap Control.Applicative.pure))))"]+                                     []+  , (,,,,,) "liftA2"     False False "Applicative f => (a -> b -> c) -> f a -> f b -> f c"+                                     ["\\f1 -> (\\f2 -> (Control.Applicative.<*>) (((Control.Applicative.<*>) (Control.Applicative.pure f1)) f2))"+                                     ,"\\f1 -> (\\f2 -> (\\d -> ((Control.Applicative.<*>) ((Data.Functor.fmap (\\j -> (\\k -> (f1 k) j))) d)) f2))"+                                     ,"\\f1 -> (\\f2 -> (Control.Applicative.<*>) ((Data.Functor.fmap f1) f2))"+                                     ,"\\f1 -> ((.) (Control.Applicative.<*>)) (Data.Functor.fmap f1)"+                                     ]+                                     ["liftA2", "liftA3"]+  , (,,,,,) "runEitherT" False False "Monad m => [D] -> (D -> Control.Monad.Trans.Either.EitherT e m [FB]) -> ([FB] -> [FB]) -> m [Data.Either.Either e [FB]]"+                                     ["\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.traverse (\\h -> Control.Monad.Trans.Either.runEitherT (((Control.Monad.>>=) (f2 h)) (\\n -> Control.Applicative.pure (f3 n))))) as))"+                                     ,"\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.traverse (((.) Control.Monad.Trans.Either.runEitherT) (((.) (Data.Functor.fmap f3)) f2))) as))"+                                     ,"\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.traverse (\\h -> Control.Monad.Trans.Either.runEitherT ((Data.Functor.fmap f3) (f2 h)))) as))"+                                     ,"\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.mapM (\\h -> Control.Monad.Trans.Either.runEitherT ((Data.Functor.fmap f3) (f2 h)))) as))"]+                                     []+  , (,,,,,) "constr"     False False "(Monad m, Ord e) => ((e -> Data.Either.Either e TC) -> A -> Control.Monad.Trans.Either.EitherT e m C) -> Data.Either.Either e TC -> Data.Map.Map e (Data.Either.Either e TC) -> [A] -> Control.Monad.Trans.Either.EitherT e m [C]"+                                     ["\\f1 -> (\\e2 -> (\\m3 -> Data.Traversable.traverse (f1 (\\l -> (Data.Maybe.fromMaybe e2) ((Data.Map.lookup l) m3)))))"+                                     ,"\\f1 -> (\\e2 -> (\\m3 -> Data.Traversable.mapM (f1 (\\l -> (Data.Maybe.fromMaybe e2) ((Data.Map.lookup l) m3)))))"+                                     ,"\\f1 -> (\\e2 -> (\\m3 -> Data.Traversable.mapM (f1 (\\l -> ((Data.Maybe.maybe e2) (\\q -> q)) ((Data.Map.lookup l) m3)))))"]+                                     []+  , (,,,,,) "fmapmap"    False False "Monad m => T -> [N] -> (CT -> N -> FB) -> (SC -> T -> m CT) -> SC -> m [FB]"+                                     ["\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (((.) Control.Applicative.pure) (f3 c11))) bs)))))"+                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (\\p -> Control.Applicative.pure ((f3 c11) p))) bs)))))"+                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (((.) Control.Applicative.pure) (f3 c11))) bs)))))"+                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (\\p -> pure ((f3 c11) p))) bs)))))"+                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.mapM (\\p -> Control.Applicative.pure ((f3 c11) p))) bs)))))"+                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> (Data.Traversable.mapM (\\j -> (Data.Functor.fmap (\\n -> (f3 n) j)) ((f4 s5) t1))) bs))))"+                                     ]+                                     []+  , (,,,,,) "fmapmap2"   False False "Monad m => T -> SC -> (T -> m [FB] -> m [FB]) -> [N] -> (SC -> T -> m CT) -> (CT -> N -> FB) -> m [FB]"+                                     ["\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.traverse (\\n12 -> ((Control.Monad.>>=) ((f5 s2) t1)) (\\s -> Control.Applicative.pure ((f6 s) n12)))) ds))))))"+                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.traverse (\\n12 -> (Data.Functor.fmap (\\c16 -> (f6 c16) n12)) ((f5 s2) t1))) ds))))))"+                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.mapM (\\n12 -> (Data.Functor.fmap (\\s -> (f6 s) n12)) ((f5 s2) t1))) ds))))))"+                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.mapM (\\n12 -> (Data.Functor.fmap (\\c16 -> (f6 c16) n12)) ((f5 s2) t1))) ds))))))"+                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.mapM (\\n12 -> ((Control.Monad.>>=) ((f5 s2) t1)) (\\s -> Control.Applicative.pure ((f6 s) n12)))) ds))))))"]+                                     []+  , (,,,,,) "contRet"    False False "a -> Control.Monad.Trans.Cont.Cont r a"+                                     ["\\a -> Control.Monad.Trans.Cont.Cont (\\f4 -> f4 a)"]+                                     []+  , (,,,,,) "contBind"   False False "Control.Monad.Trans.Cont.Cont r a -> (a -> Control.Monad.Trans.Cont.Cont r b) -> Control.Monad.Trans.Cont.Cont r b"+                                     ["\\c1 -> (\\f2 -> let (Control.Monad.Trans.Cont.Cont f4) = c1 in Control.Monad.Trans.Cont.Cont (\\f6 -> f4 (\\i -> let (Control.Monad.Trans.Cont.Cont f13) = f2 i in f13 f6)))"]+                                     []+  , (,,,,,) "ap"         False False "Monad m => m (a->b) -> m a -> m b"+                                     ["(Control.Applicative.<*>)"]+                                     []+  ]++{-+  , (,) "liftBlub"+    (ExpLambda 1+      (ExpLambda 2+        (ExpLambda 3+          (ExpApply+            (ExpApply (ExpLit "(>>=)") (ExpVar 1))+            (ExpLambda 7+              (ExpApply+                (ExpApply (ExpLit "(>>=)") (ExpVar 2))+                (ExpLambda 11+                  (ExpApply+                    (ExpApply (ExpVar 3) (ExpVar 7))+                    (ExpVar 11)))))))))+-}++exampleInput :: [(String, Bool, Bool, String)]+exampleInput =+  [ (,,,) "State"      False False "(s -> (a, s)) -> State s a"+  , (,,,) "showmap"    False False "(Show b) => (a -> b) -> [a] -> [String]"+  , (,,,) "ffbind"     False False "(a -> t -> b) -> (t -> a) -> (t -> b)"+  , (,,,) "join"       False False "(Monad m) => m (m a) -> m a"+  , (,,,) "fjoin"      False False "(t -> (t -> a)) -> t -> a"+  , (,,,) "zipThingy"  False False "[a] -> b -> [(a, b)]"+  , (,,,) "stateRun"   True  False "State a b -> a -> b"+  , (,,,) "fst"        True  False "(a, b) -> a"+  , (,,,) "ffst"       True  False "(a -> (b, c)) -> a -> b"+  , (,,,) "snd"        True  False "(a, b) -> b"+  , (,,,) "quad"       False False "a -> ((a, a), (a, a))"+  , (,,,) "fswap"      False False "(a -> (b, c)) -> a -> (c, b)"+  , (,,,) "liftBlub"   False False "Monad m => m a -> m b -> (a -> b -> m c) -> m c"+  , (,,,) "stateBind"  False False "State s a -> (a -> State s b) -> State s b"+  , (,,,) "dbMaybe"    False False "Maybe a -> Maybe (a, a)"+  , (,,,) "tupleShow"  False False "Show a, Show b => (a, b) -> String"+  , (,,,) "FloatToInt" False False "Float -> Int"+  , (,,,) "FloatToIntL" False False "[Float] -> [Int]"+  , (,,,) "longApp"    False False "a -> b -> c -> (a -> b -> d) -> (a -> c -> e) -> (b -> c -> f) -> (d -> e -> f -> g) -> g"+  , (,,,) "liftSBlub"  False False "Monad m, Monad n => ([a] -> b -> c) -> m ([n a]) -> m (n b) -> m (n c)"+  , (,,,) "liftSBlubS" False False "Monad m => (List a -> b -> c) -> m ([Maybe a]) -> m (Maybe b) -> m (Maybe c)"+  , (,,,) "joinBlub"   False False "Monad m => [Decl] -> (Decl -> m [FunctionBinding] -> m [FunctionBinding]"+  , (,,,) "liftA2"     False False "Applicative f => (a -> b -> c) -> f a -> f b -> f c"+  ]++filterBindings :: (QualifiedName -> Bool)+               -> [FunctionBinding]+               -> [FunctionBinding]+filterBindings p = filter $ \(_, qn, _, _, _) -> p qn++filterBindingsSimple :: [String]+                     -> [FunctionBinding]+                     -> [FunctionBinding]+filterBindingsSimple es = filterBindings $ \n -> case n of+  QualifiedName _ name -> name `notElem` es+  _                    -> True++checkInput :: ( m ~ MultiRWST r w s m0+              , Monad m0+              , Functor m0+              , ContainsType TypeDeclMap r+              )+           => ExferenceHeuristicsConfig+           -> EnvDictionary+           -> String+           -> Bool+           -> Bool+           -> [String]+           -> m ExferenceInput+checkInput heuristics (bindings, deconss, sEnv) typeStr allowUnused patternM hidden = do+  tDeclMap <- mAsk+  ty <- unsafeReadType (sClassEnv_tclasses sEnv) exampleDataTypes tDeclMap typeStr+  let filteredBindings = filterBindingsSimple ("fix":"forever":"iterateM_":hidden) bindings+  return $ ExferenceInput+    ty+    filteredBindings+    deconss+    sEnv+    allowUnused+    False+    8192+    patternM+    20000+    (Just 8192)+    heuristics++exampleDataTypes :: [QualifiedName]+exampleDataTypes+  = parseQualifiedName <$> [ "Data.String.String"+                           , "Prelude.Float"+                           , "Data.Int.Int"+                           , "Data.Bool.Bool"+                           ]++checkExpectedResults :: forall m m0 r w s+                      . ( m ~ MultiRWST r w s m0+                        , Monad m0+                        , Functor m0+                        , ContainsType TypeDeclMap r+                        )+                     => ExferenceHeuristicsConfig+                     -> EnvDictionary+                     -> m [ ( String -- ^ name+                            , [String] -- ^ expected+                            , Maybe ( (Expression, ExferenceStats)+                                      -- ^ first+                                    , Maybe (Int, ExferenceStats)+                                    ) -- ^ index and stats of expected+                            )]+checkExpectedResults heuristics env = mapMultiRWST (return . runIdentity)+                                      -- for lazyness, we drop the IO+                                    $ sequence+  [ [ (name, expected, r)+    | input <- checkInput heuristics env typeStr allowUnused patternM hidden+    , let getExp :: (Expression, [HsConstraint], ExferenceStats)+                 -> MaybeT (MultiRWST r w s Identity) ExferenceStats+          getExp (e, _, s) =+            [ s+            | showExpression (simplifyExpression e) `elem` expected+            ]+    , let xs = findExpressions input+    , r <- runMaybeT+        [ ((simplifyExpression e, stats), rs)+        | let ((e, _, stats):_) = xs+        , rs <- lift $ runMaybeT $ asum $ zipWith (fmap . (,)) [0..] $ map getExp xs+        ]+    ]+  | (name, allowUnused, patternM, typeStr, expected, hidden) <- checkData+  ]+++{-+checkBestResults :: ExferenceHeuristicsConfig+                 -> EnvDictionary+                 -> [ ( String+                      , [String]+                      , Maybe ( (Expression, ExferenceStats)+                                  -- ^ first result+                              , (Int, Expression, ExferenceStats)+                                  -- ^ best result+                              , Maybe (Int, ExferenceStats)+                                  -- ^ expected+                              )+                      )]+checkBestResults heuristics env = do+  (name, allowUnused, typeStr, expected) <- checkData+  let input = checkInput heuristics env typeStr allowUnused+  let getBest :: [(Expression, ExferenceStats)]+              -> (Int, Expression, ExferenceStats)+      getBest = maximumBy (comparing g) . zipWith (\a (b,c) -> (a,b,c)) [0..]+        where+          g (_,_,ExferenceStats _ f) = f+  let getExp :: Int+             -> [(Expression, ExferenceStats)]+             -> Maybe (Int, ExferenceStats)+      getExp _ [] = Nothing+      getExp n ((e,s):r) | show e `elem` expected = Just (n,s)+                         | otherwise              = getExp (n+1) r+  return $+    ( name+    , expected+    , case findExpressions input of+        [] -> Nothing+        xs@(x:_) -> Just (x, getBest xs, getExp 0 xs)+    )+-}++{-+checkBestResultsPar :: ExferenceHeuristicsConfig+                    -> EnvDictionary+                    -> [ IO ( String+                            , [String]+                            , Maybe ( (Expression, ExferenceStats)+                                        -- ^ first result+                                    , (Int, Expression, ExferenceStats)+                                        -- ^ best result+                                    , Maybe (Int, ExferenceStats)+                                        -- ^ expected+                                    )+                            )]+-}++{-+checkResults :: ExferenceHeuristicsConfig+             -> EnvDictionary+             -> [IO ( String -- name+                    , [String] -- expected+                    , Maybe Expression -- first+                    , Maybe Expression -- best+                    , Maybe (Int, ExferenceStats) -- expected was nth solution+                                                  -- and had these stats+                    , [(Expression, ExferenceStats)]+                    )]+checkResults heuristics (bindings, sEnv) = do+  (name, allowUnused, typeStr, expected) <- checkData+  let input = ExferenceInput+                (readConstrainedType sEnv typeStr)+                (filter (\(x,_,_) -> x/="join" && x/="liftA2") bindings)+                sEnv+                allowUnused+                131072+                (Just 131072)+                heuristics+  let r = findExpressionsPar input+  let finder :: Int+             -> [(Expression, ExferenceStats)]+             -> Maybe (Int, ExferenceStats)+      finder n [] = Nothing+      finder n ((e, s):r) | show e `elem` expected = Just (n, s)+                          | otherwise = finder (n+1) r+      bestFound = findSortNExpressions 100 input+  return $ (,,,,,)+         <$> return name+         <*> return expected+         <*> fmap fst <$> findOneExpressionPar input+         -- <*> return (fst <$> findOneExpression input)+         <*> return (fst <$> listToMaybe bestFound)+         <*> (finder 0 <$> r)+         <*> r+-}++exampleOutput :: ( m ~ MultiRWST r w s m0+                 , Monad m0+                 , Functor m0+                 )+              => ExferenceHeuristicsConfig+              -> EnvDictionary+              -> m [[(Expression, [HsConstraint], ExferenceStats)]]+exampleOutput heuristics (bindings, deconss, sEnv) =+  exampleInput `forM` \(_, allowUnused, patternM, s) -> do+    ty <- unsafeReadType (sClassEnv_tclasses sEnv) exampleDataTypes (M.empty) s+    let filteredBindings = filterBindingsSimple ["join", "liftA2"] bindings+    return $ takeFindSortNExpressions 10 10 $ ExferenceInput+                ty+                filteredBindings+                deconss+                sEnv+                allowUnused+                False+                8192+                patternM+                32768+                (Just 32768)+                heuristics++exampleInOut :: ( m ~ MultiRWST r w s m0+                , Monad m0+                , Functor m0+                )+             => ExferenceHeuristicsConfig+             -> EnvDictionary+             -> m [( (String, Bool, Bool, String)+                   , [(Expression, [HsConstraint], ExferenceStats)]+                   )]+exampleInOut h env =+  zip exampleInput <$> exampleOutput h env++printAndStuff :: ExferenceHeuristicsConfig+              -> EnvDictionary+              -> MultiRWST r w s IO ()+printAndStuff h env = exampleInOut h env >>= mapM_ f+  where+    f ((name, _, _, _), []) = lift $ putStrLn $ "no results for "++name++"!"+    f ((name, _, _, _), results) = mapM_ g results+      where+        g (expr, _, ExferenceStats n d m) = do+          {-+          if doPf then do+            pf <- pointfree $ str+            putStrLn $ name ++ " = " ++ pf+                       ++ "    FROM    " ++ name ++ " = " ++ str+                       ++ " (depth " ++ show d ++ ", " ++ show n ++ " steps)"+           else+          -}+          lift $ putStrLn $ name ++ " = " ++ showExpression expr+                            ++ " (depth "+                            ++ show d+                            ++ ", "+                            ++ show n+                            ++ " steps, "+                            ++ show m+                            ++ " max pqueue size)"++printStatistics :: ExferenceHeuristicsConfig+                -> EnvDictionary+                -> MultiRWST r w s IO ()+printStatistics h env = exampleInOut h env >>= mapM_ f+  where+    f ((name, _, _, _), [])      = lift $ putStrLn $ printf "%10s: ---" name+    f ((name, _, _, _), results) =+      let (hd, avg, minV, maxV, n) = getStats results+      in lift $ putStrLn+              $ printf "%12s: head=%6d avg=%6d min=%6d max=%6d %s" name hd avg minV maxV+                                     (if n==6 then "" else " n = " ++ show n)+    getStats results =+      let steps = map (\(_, _, stats) -> exference_steps stats) results+      in ( head steps+         , sum steps `div` length steps+         , minimum steps+         , maximum steps+         , length steps+         )++printCheckExpectedResults :: forall r w s+                           . ( ContainsType TypeDeclMap r+                             )+                          => ExferenceHeuristicsConfig+                          -> EnvDictionary+                          -> MultiRWST r w s IO ()+printCheckExpectedResults h env = do+    xs <- checkExpectedResults h env+    case () of { () -> do+    stats <- mapM helper xs+    lift $ putStrLn $ "total:     " ++ show (length stats)+    lift $ putStrLn $ "solutions: " ++ (show+                                       $ length+                                       $ catMaybes+                                       $ fst <$> stats)+    lift $ putStrLn $ "success:   " ++ ( show+                                       $ length+                                       $ filter id+                                       $ catMaybes+                                       $ uncurry (liftM2 (==)) <$> stats)+    lift $ putStrLn $ "rating any solutions: "+             ++ ( show+                $ foldr g (0, 0.0)+                $ fromMaybe (ExferenceStats 1000000 1000000 0) . fst <$> stats)+    lift $ putStrLn $ "rating good solutions: "+             ++ ( show+                $ foldr g (0, 0.0)+                $ fromMaybe (ExferenceStats 1000000 1000000 0) . snd <$> stats)+  where+    helper :: ( String -- ^ name+              , [String] -- ^ expected+              , Maybe ( (Expression, ExferenceStats) -- ^ first+                      , Maybe (Int, ExferenceStats)+                      ) -- ^ index and stats of expected+              )+           -> MultiRWST r w s IO (Maybe ExferenceStats, Maybe ExferenceStats)+    helper (name, _, Nothing) = do+      lift $ putStrLn $ printf "%-12s: no solutions found at all!" name+      return (Nothing, Nothing)+    helper (name, e, Just ((first,stats), Nothing)) = do+      lift $ putStrLn $ printf "%-12s: expected solution not found!" name+      let firstStr = showExpression first+      lift $ putStrLn $ "  first solution:       " ++ firstStr+      lift $ putStrLn $ "  first solution stats: " ++ show stats+      lift $ putStrLn $ "  expected solutions:   " ++ intercalate+                     "\n                      or " e+      lift $ putStrLn $ "  " ++ show firstStr+      return (Just stats, Nothing)+    helper (name, _, Just (_, Just (0, stats))) = do+      lift $ putStrLn $ printf "%-12s: %s" name (show stats)+      return (Just stats, Just stats)+    helper (name, e, Just ((first, fstats), Just (n, stats))) = do+      lift $ putStrLn $ printf "%-12s: expected solution not first, but %d!" name n+      lift $ putStrLn $ "  first solution:     " ++ showExpression first+      lift $ putStrLn $ "  expected solutions:   " ++ intercalate+                      "\n                     or " e+      lift $ putStrLn $ "  first solution stats:    " ++ show fstats+      lift $ putStrLn $ "  expected solution stats: " ++ show stats+      lift $ putStrLn $ "  " ++ show (showExpression first)+      return (Just fstats, Just stats)+    g :: ExferenceStats -> (Int,Float) -> (Int,Float)+    g (ExferenceStats a b _) (d,e) = (a+d,b+e)+  }++printMaxUsage :: ExferenceHeuristicsConfig+              -> EnvDictionary+              -> MultiRWST r w s IO ()+printMaxUsage h (bindings, deconss, sEnv) = sequence_ $ do+  (name, allowUnused, patternM, typeStr, _expected, hidden) <- checkData+  return $ do+    ty <- unsafeReadType (sClassEnv_tclasses sEnv) exampleDataTypes (M.empty) typeStr+    let filteredBindings = filterBindingsSimple hidden bindings+    let input = ExferenceInput+                  ty+                  filteredBindings+                  deconss+                  sEnv+                  allowUnused+                  False+                  8192+                  patternM+                  16384+                  (Just 16384)+                  h+    let stats = chunkBindingUsages $ last $ findExpressionsWithStats input+        highest = take 5 $ sortBy (flip $ comparing snd) $ M.toList stats+    lift $ putStrLn $ printf "%-12s: %s" name (show highest)++#if BUILD_SEARCH_TREE+printSearchTree :: ( ContainsType QNameIndex s )+                => ExferenceHeuristicsConfig+                -> EnvDictionary+                -> MultiRWST r w s IO ()+printSearchTree h (bindings, deconss, sEnv) = sequence_ $ do+  (name, allowUnused, patternM, typeStr, _expected, hidden) <- checkData+  return $ do+    ty <- unsafeReadType (sClassEnv_tclasses sEnv) exampleDataTypes (M.empty) typeStr+    filteredBindings <- filterBindingsSimple hidden bindings+    let input = ExferenceInput+                  ty+                  filteredBindings+                  deconss+                  sEnv+                  allowUnused+                  False+                  8192+                  patternM+                  256+                  (Just 256)+                  h+    let tree = chunkSearchTree $ last $ findExpressionsWithStats input+    let showf (total,processed,expression)+          = printf "%d (+%d): %s" processed+                                  (total-processed)+                                  (showExpressionPure qNameIndex expression)+    lift $ putStrLn+         $ name+    lift $ putStrLn+         $ drawTree+         $ fmap showf+         $ filterSearchTreeProcessedN 2+         $ tree+#endif

+ src/Flags_exference.hs view

@@ -0,0 +1,19 @@+module Flags_exference+  ( linkNodes+  , buildSearchTree+  )+where++linkNodes :: Bool+#if LINK_NODES+linkNodes = True+#else+linkNodes = False+#endif++buildSearchTree :: Bool+#if BUILD_SEARCH_TREE+buildSearchTree = True+#else+buildSearchTree = False+#endif

+ src/Language/Haskell/Exference.hs view

@@ -0,0 +1,193 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MultiWayIf #-}++module Language.Haskell.Exference+  ( findExpressions+  , findOneExpression+  , findSortNExpressions+  , findBestNExpressions+  , findFirstBestExpressions+  , takeFindSortNExpressions+  , findFirstExpressionLookahead+  , findFirstBestExpressionsLookahead+  , findFirstBestExpressionsLookaheadPreferNoConstraints+  , ExferenceInput ( .. )+  , ExferenceOutputElement+  , ExferenceStats (..)+  )+where++++import Language.Haskell.Exference.Core++import Language.Haskell.Exference.Core.ExferenceStats++import Data.Maybe ( maybeToList, listToMaybe, fromMaybe )+import Control.Arrow ( first, second, (***) )+import Control.Monad ( guard, mzero )+import Control.Applicative ( (<$>), (<*>) )+import Data.List ( partition, sortBy, groupBy, minimumBy )+import Data.Ord ( comparing )+import Data.Function ( on )++import Debug.Trace++++-- returns the first found solution (not necessarily the best overall)+findOneExpression :: ExferenceInput+                  -> Maybe ExferenceOutputElement+findOneExpression = listToMaybe . findExpressions++-- calculates at most n solutions, sorts by rating, returns the first m+takeFindSortNExpressions :: Int+                         -> Int+                         -> ExferenceInput+                         -> [ExferenceOutputElement]+takeFindSortNExpressions m n =+  take m . findSortNExpressions n++-- calculates at most n solutions, and returns them sorted by their rating+findSortNExpressions :: Int+                     -> ExferenceInput+                     -> [ExferenceOutputElement]+findSortNExpressions n input = sortBy (comparing g) $ take n $ r+  where+    r = findExpressions input+    g (_, _, ExferenceStats _ f _) = f++-- returns the first expressions with the best rating.+-- best explained on examples:+--   []      -> []+--   [2,5,5] -> [2]+--   [3,3,3,4,4,5,6,7] -> [3,3,3]+--   [2,5,2] -> [2] -- will not look past worse ratings+--   [4,3,2,2,2,3] -> [2,2,2] -- if directly next is better, switch to that+findFirstBestExpressions :: ExferenceInput+                         -> [ExferenceOutputElement]+findFirstBestExpressions input+  | r <- findExpressions input+  , f <- head . groupBy (\(~(_, _, stats1)) (~(_, _, stats2)) -> +                              exference_complexityRating stats1+                           >= exference_complexityRating stats2)+  = case r of+    [] -> []+    _  -> f $ reverse $ f $ r++-- tries to find the best solution by performing a limitted amount of steps,+-- resetting the count whenever a better solution is found.+-- "finds the "first" (by some metric) local maximum"+-- advantages:+--   - might be able to find a "best" solution quicker than other approaches+--   - does not calculate the maximum amount of steps when there is no+--     solution left.+-- disadvantages:+--   - might find only a local optimum+findFirstExpressionLookahead :: Int+                             -> ExferenceInput+                             -> Maybe ExferenceOutputElement+findFirstExpressionLookahead n = f 999999 Nothing . findExpressionsChunked+  where+    f :: Int+      -> Maybe ExferenceOutputElement+      -> [[ExferenceOutputElement]]+      -> Maybe ExferenceOutputElement+    f _ best     []      = best+    f 0 best     _       = best+    f r best     ([]:sr) = f (r-1) best sr+    f _ Nothing  (s:sr)  = f n (Just $ minElem s) sr+    f r (Just (b@(_, _, statsB))) (s:sr) +                         | sbest@(_, _, statsBest) <- minElem s+                         , exference_complexityRating statsBest+                         < exference_complexityRating statsB+                         = f n (Just sbest) sr+                         | otherwise = f (r-1) (Just b) sr+    minElem :: [ExferenceOutputElement] -> ExferenceOutputElement+    minElem = minimumBy (\(~(_, _, stats1)) (~(_, _, stats2)) ->+                           compare (exference_complexityRating stats1)+                                   (exference_complexityRating stats2))++-- a combination of the return-multiple-if-same-rating and the+-- look-some-steps-ahead-for-better-solution functionalities.+-- for example,+-- [2,3,2,2,4,5,6,7] -> [2,2,2]+--  does not stop at 3, but looks ahead, then returns all the 2-rated solutions+findFirstBestExpressionsLookahead :: Int+                                  -> ExferenceInput+                                  -> [ExferenceOutputElement]+findFirstBestExpressionsLookahead n =+  f 999999 99999.9 [] . findExpressionsChunked+ where+  f :: Int+    -> Float+    -> [ExferenceOutputElement]+    -> [[ExferenceOutputElement]]+    -> [ExferenceOutputElement]+  f _ _ ss []           = ss+  f 0 _ ss _            = ss+  f i r ss ([]:qss)     = f (i-1) r ss qss+  f i r ss ((q@(_, _, statsQ):qs):qss)+                        | rq <- exference_complexityRating statsQ+                        = if+                        | rq < r    -> f n rq [q] (qs:qss)+                        | rq == r   -> f n r (q:ss) (qs:qss)+                        | otherwise -> f i r ss (qs:qss)++-- a combination of the return-multiple-if-same-rating and the+-- look-some-steps-ahead-for-better-solution functionalities.+-- for example,+-- [2,3,2,2,4,5,6,7] -> [2,2,2]+--  does not stop at 3, but looks ahead, then returns all the 2-rated solutions+findFirstBestExpressionsLookaheadPreferNoConstraints :: Int+                                                     -> ExferenceInput+                                                     -> [ExferenceOutputElement]+findFirstBestExpressionsLookaheadPreferNoConstraints n =+  f 999999 99999.9 [] [] . findExpressionsChunked+ where+  f :: Int+    -> Float+    -> [ExferenceOutputElement] -- solutions without constraints+    -> [ExferenceOutputElement] -- solution(s) with constraints+    -> [[ExferenceOutputElement]]+    -> [ExferenceOutputElement]+  -- out of potential solutions, nothing constraint-free found+  f _ _ [] ssc []           = ssc+  -- out of potential solutions, found good stuff+  f _ _ ss _   []           = ss+  -- out of lookahead, return what we have (ss wont be null)+  f 0 _ ss _   _            = ss+  -- simple reduce when no good solutions yet+  f i r [] ssc ([]:qss)     = f i r [] ssc qss+  -- lookahead step when we already have some good solution+  f i r ss ssc ([]:qss)     = f (i-1) r ss ssc qss+  -- finding one/the first good solution+  f i r ss _   ((q@(_, [], statsQ):qs):qss)+                        | rq <- exference_complexityRating statsQ+                        = if+                        | null ss   -> f n rq [q] [] (qs:qss)+                        | rq < r    -> f n rq [q] [] (qs:qss)+                        | rq == r   -> f n r (q:ss) [] (qs:qss)+                        | otherwise -> f i r ss [] (qs:qss)+  -- finding a bad solution when there are no good solutions yet+  f i r [] ssc ((q@(_, _, statsQ):qs):qss)+                        | rq <- exference_complexityRating statsQ+                        = if+                        | rq < r    -> f i rq [] [q] (qs:qss)+                        | rq == r   -> f i r [] (q:ssc) (qs:qss)+                        | otherwise -> f i r [] ssc (qs:qss)+  -- finding a bad solution when we already have good solutions+  f i r ss _   ((_:qs):qss) = f (i-1) r ss [] (qs:qss)++-- like findSortNExpressions, but retains only the best rating+findBestNExpressions :: Int+                     -> ExferenceInput+                     -> [ExferenceOutputElement]+findBestNExpressions n input+  | r <- findSortNExpressions n input+  = case r of+    [] -> []+    _  -> head $ groupBy (\(~(_, _, stats1)) (~(_, _, stats2)) -> +                              exference_complexityRating stats1+                           >= exference_complexityRating stats2)+                         r

+ src/Language/Haskell/Exference/BindingsFromHaskellSrc.hs view

@@ -0,0 +1,204 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonadComprehensions #-}++module Language.Haskell.Exference.BindingsFromHaskellSrc+  ( getDecls+  , declToBinding+  , getDataConss+  , getClassMethods+  , getDataTypes+  )+where++++import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Pretty+import Language.Haskell.Exference.Core.FunctionBinding+import Language.Haskell.Exference.TypeFromHaskellSrc+import Language.Haskell.Exference.TypeDeclsFromHaskellSrc+import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.FunctionDecl++import Control.Applicative ( (<$>), (<*>) )++import Control.Monad ( join )+import Control.Monad.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Either+import Control.Monad.State.Strict+import qualified Data.Map as M+import Data.List ( find )++import Control.Monad.Trans.MultiRWS+import Data.HList.ContainsType++import Debug.Trace++++getDecls+  :: (Monad m, Functor m)+  => [QualifiedName]+  -> [HsTypeClass]+  -> TypeDeclMap+  -> [Module]+  -> MultiRWST r w s m [Either String HsFunctionDecl]+getDecls ds tcs tDeclMap modules = fmap (>>= either (return.Left) (map Right))+                                $ sequence+                                $ do+  Module _loc mn _pragma _warning _mexp _imp decls <- modules+  d <- decls+  return $ runEitherT $ transformDecl tcs ds mn tDeclMap d++transformDecl+  :: (Monad m, Functor m)+  => [HsTypeClass]+  -> [QualifiedName]+  -> ModuleName+  -> TypeDeclMap+  -> Decl+  -> EitherT String (MultiRWST r w s m) [HsFunctionDecl]+transformDecl tcs ds mn tDeclMap (TypeSig _loc names qtype)+  = insName qtype $ do+      (ctype, _) <- convertType tcs (Just mn) ds tDeclMap qtype+      return $ helper mn ctype <$> names+transformDecl _ _ _ _ _ = return []++transformDecl'+  :: (MonadMultiState ConvData m, Monad m, Functor m)+  => [HsTypeClass]+  -> [QualifiedName]+  -> ModuleName+  -> TypeDeclMap+  -> Decl+  -> EitherT String m [HsFunctionDecl]+transformDecl' tcs ds mn tDeclMap (TypeSig _loc names qtype)+  = insName qtype $ do+      ctype <- convertTypeInternal tcs (Just mn) ds tDeclMap qtype+      return $ helper mn ctype <$> names+transformDecl' _ _ _ _ _ = return []++insName :: (Functor m, Monad m)+        => Type -> EitherT String m a -> EitherT String m a+insName qtype = bimapEitherT (\x -> x ++ " in " ++ prettyPrint qtype) id++helper :: ModuleName -> HsType -> Name -> HsFunctionDecl+helper mn t x = (convertModuleName mn x, forallify t)++getDataConss+  :: (Monad m)+  => [HsTypeClass]+  -> [QualifiedName]+  -> TypeDeclMap+  -> [Module]+  -> MultiRWST+       r+       w+       s+       m+       [Either String ([HsFunctionDecl], DeconstructorBinding)]+getDataConss tcs ds tDeclMap modules = sequence $ do+  Module _loc moduleName _pragma _warning _mexp _imp decls <- modules+  DataDecl _loc _newtflag cntxt name params conss _derives <- decls+  let+    rTypeM :: ( MonadMultiState ConvData m )+           => EitherT String m HsType+    rTypeM = do+      let rName = convertModuleName moduleName name+      ps  <- mapM pTransform params+      return $ (forallify . foldl TypeApp (TypeCons rName)) ps+    pTransform :: MonadMultiState ConvData m => TyVarBind -> EitherT String m HsType+    pTransform (KindedVar _ _) = left "KindedVar"+    pTransform (UnkindedVar n) = TypeVar <$> getVar n+  --let+  --  tTransform (UnBangedTy t) = convertTypeInternal t+  --  tTransform x              = lift $ left $ "unknown Type: " ++ show x+  let+    typeM :: ( MonadMultiState ConvData m )+          => QualConDecl+          -> EitherT String m (QualifiedName, [HsType])+    typeM (QualConDecl _loc cbindings ccntxt conDecl) = do+      case cntxt of+        [] -> right ()+        _  -> left "context in data type"+      case (cbindings, ccntxt) of+        ([],[]) -> right ()+        _       -> left "constraint or existential type for constructor"+      (cname,tys) <- case conDecl of+        ConDecl c t -> right (c, t)+        x           -> left $ "unknown ConDecl: " ++ show x+      convTs <- convertTypeInternal tcs (Just moduleName) ds tDeclMap `mapM` tys+      let qName = convertModuleName moduleName cname+      return $ (qName, convTs)+  let+    addConsMsg = (++) $ show name ++ ": "+  let+    convAction :: ( MonadMultiState ConvData m )+               => EitherT String m ([HsFunctionDecl], DeconstructorBinding)+    convAction = do+      rtype  <- rTypeM+      consDatas <- mapM typeM conss+      return $ ( [ (n, foldr TypeArrow rtype ts)+                 | (n, ts) <- consDatas+                 ]+               , (rtype, consDatas, False)+               )+        -- TODO: actually determine if stuff is recursive or not+  return $ do+    convResult <- withMultiStateA (ConvData 0 M.empty) $ runEitherT convAction+    return $ either (Left . addConsMsg) Right convResult+    -- TODO: replace this by bimap..++getClassMethods+  :: (Monad m, Functor m)+  => [HsTypeClass]+  -> [QualifiedName]+  -> TypeDeclMap+  -> [Module]+  -> MultiRWST r w s m [Either String HsFunctionDecl]+getClassMethods tcs ds tDeclMap modules = fmap join $ sequence $ do+  Module _loc moduleName _pragma _warning _mexp _imp decls <- modules+  ClassDecl _ _ name@(Ident nameStr) vars _ cdecls <- decls+  return $ do+    let errorMod = (++) ("class method for "++show name++": ")+    let tcsTuples = (\tc -> (tclass_name tc, tc)) <$> tcs+    let searchF (QualifiedName _ n) = n==nameStr+        searchF _                   = False+    let maybeClass = snd <$> find (searchF . fst) tcsTuples+    case maybeClass of+      Nothing -> return [Left $ "unknown type class: "++show name]+      Just cls -> do+        let cnstrA = HsConstraint cls <$> mapM ((TypeVar <$>) . tyVarTransform) vars+        --     action :: ( MonadMultiState ConvData m ) => m [Either String [HsFunctionDecl]]+        rEithers <- withMultiStateA (ConvData 0 M.empty) $ do+          cnstrE <- runEitherT cnstrA+          case cnstrE of+            Left x -> return [Left x]+            Right cnstr ->+              mapM ( runEitherT+                   . fmap (map (addConstraint cnstr))+                   . transformDecl' tcs ds moduleName tDeclMap)+                $ [ d | ClsDecl d <- cdecls ]+        let _ = rEithers :: [Either String [HsFunctionDecl]]+        return $ concatMap (either (return . Left . errorMod) (map Right))+               $ rEithers+  where+    addConstraint :: HsConstraint -> HsFunctionDecl -> HsFunctionDecl+    addConstraint c (n, TypeForall vs cs t) = (n, TypeForall vs (c:cs) t)+    addConstraint _ _                       = error "addConstraint for non-forall type = bad"+      --(n, ForallType [] [c] t)++getDataTypes :: [Module] -> [QualifiedName]+getDataTypes modules = d1 ++ d2+ where+  d1 = do+    Module _loc moduleName _pragma _warning _mexp _imp decls <- modules+    DataDecl _ _ _ name _ _ _ <- decls+    return $ convertModuleName moduleName name+  d2 = do+    Module _loc moduleName _pragma _warning _mexp _imp decls <- modules+    TypeDecl _ name _ _ <- decls+    return $ convertModuleName moduleName name

+ src/Language/Haskell/Exference/ClassEnvFromHaskellSrc.hs view

@@ -0,0 +1,165 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MonadComprehensions #-}++module Language.Haskell.Exference.ClassEnvFromHaskellSrc+  ( getClassEnv+  )+where++++import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Pretty+import Language.Haskell.Exference.Core.FunctionBinding+import Language.Haskell.Exference.TypeFromHaskellSrc+import Language.Haskell.Exference.TypeDeclsFromHaskellSrc+import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils++import qualified Data.Map.Strict as M+import qualified Data.Map.Lazy as LazyMap+import Control.Monad.State.Strict+import Control.Monad.Trans.Either+import Control.Monad.Writer.Strict++import Control.Applicative ( (<$>), (<*>), Applicative )++import Data.Maybe ( fromMaybe, mapMaybe )+import Data.Either ( lefts, rights )+import Data.List ( find )+import Data.Traversable ( traverse, for )++import Control.Monad.Trans.MultiRWS+import Data.HList.ContainsType++import Debug.Trace++++-- | returns the environment and the number of class instances+--   found (before inflating the instances). The number of+--   classes can be derived from the other output.+--   The count may be used to inform the user (post-inflation count+--   would be bad for that purpose.)+getClassEnv :: ( ContainsType [String] w+               , MonadFix m+               , Applicative m+               )+            => [QualifiedName]+            -> TypeDeclMap+            -> [Module]+            -> MultiRWST r w s m (StaticClassEnv, Int)+getClassEnv ds tDeclMap ms = do+  etcs <- getTypeClasses ds tDeclMap ms+  mapM_ (mTell . (:[])) $ lefts etcs+  let tcs = rights etcs+  einsts <- getInstances tcs ds tDeclMap ms+  mapM_ (mTell . (:[])) $ lefts einsts+  let insts_uninflated = rights einsts+  let insts = inflateInstances insts_uninflated+  return (mkStaticClassEnv tcs insts, length insts_uninflated)++type TempAsst = (QualifiedName, [HsType])++getTypeClasses :: forall m r w s m0+                . ( MonadFix m0+                  , Applicative m0+                  , m ~ MultiRWST r w s m0+                  )+               => [QualifiedName]+               -> TypeDeclMap+               -> [Module]+               -> m [Either String HsTypeClass]+getTypeClasses ds tDeclMap ms = do+  secondMap :: M.Map QualifiedName (Either String ([TempAsst], [TVarId])) <-+    fmap M.fromList $ sequence+      [ [ (qn, x) --m (inner) -- []+        | let qn = convertModuleName moduleName name+        , x <- withMultiStateA (ConvData 0 M.empty) $ runEitherT $ let+              convF (ClassA qname types) =+                (,) (convertQName    (Just moduleName) ds qname)+                <$> types `forM` convertTypeInternal [] (Just moduleName) ds tDeclMap+              convF (ParenA c) = convF c+              convF c = left $ "unknown HsConstraint: " ++ show c+            in (,) <$> mapM convF context <*> mapM tyVarTransform vars+        ]+      | Module _ moduleName _ _ _ _ decls <- ms+      , ClassDecl _loc context name vars _fdeps _cdecls <- decls+      ]+  let+    helper :: QualifiedName+           -> Either String ([TempAsst], [TVarId])+           -> Either String HsTypeClass+    helper qnid eTcRawData = do+      (tempAssts, tVarIds) <- eTcRawData+      HsTypeClass qnid tVarIds+        <$> tempAssts `forM` \(cQnid, vars) ->+          flip HsConstraint vars <$> M.findWithDefault (Right unknownTypeClass) cQnid resultMap++    resultMap :: LazyMap.Map QualifiedName (Either String HsTypeClass)+      -- CARE: DONT USE STRICT METHODS ON THIS MAP+      --       (COMPILER WONT COMPLAIN)+    resultMap = LazyMap.mapWithKey helper secondMap+  return $ LazyMap.elems $ resultMap++getInstances :: forall m m0 r w s+              . ( m ~ MultiRWST r w s m0+                , Monad m0+                )+             => [HsTypeClass]+             -> [QualifiedName]+             -> TypeDeclMap+             -> [Module]+             -> m [Either String HsInstance]+getInstances tcs ds tDeclMap ms = sequence $ do+  Module _ mn _ _ _ _ decls <- ms+  InstDecl _ _ _vars cntxt qname tps _ <- decls+    -- vars would be the forall binds in+    -- > instance forall a . Show (Foo a) where [..]+    -- which we can ignore, right?+  let name = convertQName (Just mn) ds qname+  return $ do+    let instClass = maybe (Left $ "unknown type class: "++show name) Right+                  $ find ((name==).tclass_name) tcs+    let+      sAction :: forall m1+               . ( MonadMultiState ConvData m1+                 )+              => EitherT String m1 HsInstance+      sAction = do+        -- varIds <- mapM tyVarTransform vars+        constrs <- cntxt `forM` \asst ->+          constrTransform+            (Just mn)+            ds+            tDeclMap+            (\str -> find ((str==).tclass_name) tcs)+            asst+        rtps <- convertTypeInternal tcs (Just mn) ds tDeclMap `mapM` tps+        ic <- hoistEither instClass+        return $ HsInstance constrs ic rtps+        -- either (Left . (("instance for "++name++": ")++)) Right+    withMultiStateA (ConvData 0 M.empty) $ runEitherT sAction++constrTransform+  :: (MonadMultiState ConvData m)+  => Maybe ModuleName+  -> [QualifiedName]+  -> TypeDeclMap+  -> (QualifiedName -> Maybe HsTypeClass)+  -> Asst+  -> EitherT String m HsConstraint+constrTransform mn ds tDeclMap tcLookupF (ClassA qname types) = do+  let ctypes = convertTypeInternal [] mn ds tDeclMap `mapM` types+  let qn = convertQName mn ds qname+  maybe+    (left $ "unknown type class: " ++ show qn)+    (\tc -> HsConstraint tc <$> ctypes)+    (tcLookupF qn)+constrTransform mn ds tDeclMap tcLookupF (ParenA c) = constrTransform mn ds tDeclMap tcLookupF c+constrTransform _ _ _ _ c = left $ "unknown HsConstraint: " ++ show c

+ src/Language/Haskell/Exference/Core.hs view

@@ -0,0 +1,31 @@+module Language.Haskell.Exference.Core+  ( findExpressions+  , findExpressionsChunked+  , findExpressionsWithStats+  , E.ExferenceHeuristicsConfig (..)+  , E.ExferenceInput (..)+  , E.ExferenceOutputElement+  , E.ExferenceChunkElement (..)+  )+where++++import qualified Language.Haskell.Exference.Core.Internal.Exference as E+import qualified Language.Haskell.Exference.Core.ExferenceStats as S+import qualified Language.Haskell.Exference.Core.SearchTree as ST+import Control.Monad ( join )+import Data.Monoid ( mempty )++++findExpressions :: E.ExferenceInput -> [E.ExferenceOutputElement]+findExpressions = concatMap E.chunkElements . E.findExpressions++findExpressionsChunked :: E.ExferenceInput+                   -> [[E.ExferenceOutputElement]]+findExpressionsChunked = map E.chunkElements . E.findExpressions++findExpressionsWithStats :: E.ExferenceInput+                         -> [E.ExferenceChunkElement]+findExpressionsWithStats = E.findExpressions

+ src/Language/Haskell/Exference/Core/ExferenceStats.hs view

@@ -0,0 +1,15 @@+module Language.Haskell.Exference.Core.ExferenceStats+  ( ExferenceStats (..)+  , BindingUsages+  )+where++import Data.Map.Strict as M+type BindingUsages = M.Map String Int++data ExferenceStats = ExferenceStats+  { exference_steps :: Int+  , exference_complexityRating :: Float+  , exference_finalSize :: Int+  }+  deriving (Show, Eq)

+ src/Language/Haskell/Exference/Core/Expression.hs view

@@ -0,0 +1,219 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Exference.Core.Expression+  ( Expression (..)+  , showExpression+  , fillExprHole+  , collectVarTypes+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Data.List ( intercalate )+import Data.Function ( on )+import Data.Maybe ( fromMaybe )+import Control.Monad ( forM, forM_, liftM )+import Data.Functor.Identity ( runIdentity )+import Data.Functor ( (<$>) )++import Control.DeepSeq.Generics+import Control.DeepSeq+import GHC.Generics++import Control.Monad.Trans.MultiRWS+import Data.HList.ContainsType++-- import Debug.Hood.Observe+import Data.Map ( Map )+import qualified Data.Map as M++++data Expression = ExpVar TVarId HsType -- a+                   -- (type is just for choosing better id when printing)+                | ExpName QualifiedName -- Prelude.zip+                | ExpLambda TVarId HsType Expression -- \x -> exp+                | ExpApply Expression Expression -- f x+                | ExpHole TVarId                 -- h+                | ExpLetMatch QualifiedName [(TVarId, HsType)] Expression Expression+                            -- let (Foo a b c) = bExp in inExp+                | ExpLet TVarId HsType Expression Expression+                            -- let x = bExp in inExp+                | ExpCaseMatch+                    Expression+                    [(QualifiedName, [(TVarId, HsType)], Expression)]+                     -- case mExp of Foo a b -> e1; Bar c d -> e2+  deriving (Eq, Generic)++instance NFData Expression where rnf = genericRnf++-- instance Show Expression where+--   showsPrec _ (ExpVar i) = showString $ showVar i+--   showsPrec d (ExpName s) = showsPrec d s+--   showsPrec d (ExpLambda i e) =+--     showParen (d>0) $ showString ("\\" ++ showVar i ++ " -> ") . showsPrec 1 e+--   showsPrec d (ExpApply e1 e2) =+--     showParen (d>1) $ showsPrec 2 e1 . showString " " . showsPrec 3 e2+--   showsPrec _ (ExpHole i) = showString $ "_" ++ showVar i+--   showsPrec d (ExpLetMatch n vars bindExp inExp) =+--       showParen (d>2)+--     $ showString ("let ("++show n++" "++intercalate " " (map showVar vars) ++ ") = ")+--     . shows bindExp . showString " in " . showsPrec 0 inExp+--   showsPrec d (ExpLet i bindExp inExp) =+--       showParen (d>2)+--     $ showString ("let " ++ showVar i ++ " = ")+--     . showsPrec 3 bindExp+--     . showString " in "+--     . showsPrec 0 inExp+--   showsPrec d (ExpCaseMatch bindExp alts) =+--       showParen (d>2)+--     $ showString ("case ")+--     . showsPrec 3 bindExp+--     . showString " of { "+--     . ( \s -> intercalate "; "+--            (map (\(cons, vars, expr) ->+--               show cons++" "++intercalate " " (map showVar vars)++" -> "+--               ++showsPrec 3 expr "")+--             alts)+--          ++ s+--       )+--     . showString " }"++refreshVarTypeBinding :: forall m+                       . MonadMultiState (Map TVarId HsType) m+                      => TVarId+                      -> HsType+                      -> m ()+refreshVarTypeBinding i ty = do+  m <- mGet+  case M.lookup i m of+    Nothing             -> mSet $ M.insert i ty m+    Just TypeVar{}      -> mSet $ M.insert i ty m+    Just TypeConstant{} -> mSet $ M.insert i ty m+    _                   -> return ()++collectVarTypes :: forall m+                 . MonadMultiState (Map TVarId HsType) m+                => Expression+                -> m ()+collectVarTypes (ExpVar i ty)       = refreshVarTypeBinding i ty+collectVarTypes ExpName{}           = return ()+collectVarTypes (ExpLambda i ty se) = do+  refreshVarTypeBinding i ty+  collectVarTypes se+collectVarTypes (ExpApply e1 e2)    = do+  collectVarTypes e1+  collectVarTypes e2+collectVarTypes ExpHole{}           = return ()+collectVarTypes (ExpLetMatch _ vars e1 e2) = do+  vars `forM_` uncurry refreshVarTypeBinding+  collectVarTypes e1+  collectVarTypes e2+collectVarTypes (ExpLet i ty e1 e2) = do+  refreshVarTypeBinding i ty+  collectVarTypes e1+  collectVarTypes e2+collectVarTypes (ExpCaseMatch se matches) = do+  collectVarTypes se+  matches `forM_` \(_, vars, me) -> do+    vars `forM_` uncurry refreshVarTypeBinding+    collectVarTypes me++showExpression :: Expression -> String+showExpression e = runIdentity+                 $ runMultiRWSTNil+                 $ withMultiStateA (M.empty :: Map TVarId HsType)+                 $ [ shs ""+                   | _ <- collectVarTypes e+                   , shs <- h 0 e+                   ]+ where+  h :: Int -> Expression -> MultiRWS r w (Map TVarId HsType ': s) ShowS+  h _ (ExpVar i _) = showString <$> showTypedVar i+  h _ (ExpName s)  = return $ shows s+  h d (ExpLambda i _ e1) =+    [ showParen (d>0) $ showString ("\\" ++ vname ++ " -> ") . eShows+    | eShows <- h 1 e1+    , vname <- showTypedVar i+    ]+  h d (ExpApply e1 e2) =+    [ showParen (d>1) $ e1Shows . showString " " . e2Shows+    | e1Shows <- h 2 e1+    , e2Shows <- h 3 e2+    ]    +  h _ (ExpHole i) = return $ showString $ "_" ++ showVar i+  h d (ExpLetMatch n vars bindExp inExp) =+    [ showParen (d>2)+    $ showString ("let ("+                  ++nStr+                  ++" "+                  ++intercalate " " varNames+                  ++ ") = ")+    . bindShows . showString " in " . inShows+    | bindShows <- h 0 bindExp+    , inShows   <- h 0 inExp+    , let nStr = show n+    , varNames  <- mapM (showTypedVar . fst) vars+    ]+      +  h d (ExpLet i _ bindExp inExp) =+    [ showParen (d>2)+    $ showString ("let " ++ varName ++ " = ")+    . bindShows+    . showString " in "+    . inShows+    | bindShows <- h 3 bindExp+    , inShows <- h 0 inExp+    , varName <- showTypedVar i+    ]+  h d (ExpCaseMatch bindExp alts) =+    [ showParen (d>2)+    $ showString "case "+    . bindShows+    . showString " of { "+    . ( \s -> intercalate "; "+           (map (\(cons, varNames, expr) ->+              cons ""++" "++intercalate " " varNames++" -> "+              ++expr "")+            altsShows)+         ++ s+      )+    . showString " }"+    | bindShows <- h 3 bindExp+    , altsShows <- alts `forM` \(cons, vars, expr) ->+        [ ( shows cons+          , varNames+          , exprShows+          )+        | exprShows <- h 3 expr+        , varNames <- mapM (showTypedVar . fst) vars+        ]+    ]++-- instance Observable Expression where+--   observer x = observeOpaque (show x) x++fillExprHole :: TVarId -> Expression -> Expression -> Expression+fillExprHole vid t orig@(ExpHole j) | vid==j = t+                                    | otherwise = orig+fillExprHole vid t (ExpLambda i ty e) = ExpLambda i ty $ fillExprHole vid t e+fillExprHole vid t (ExpApply e1 e2) = ExpApply (fillExprHole vid t e1)+                                               (fillExprHole vid t e2)+fillExprHole vid t (ExpLetMatch n vars bindExp inExp) =+  ExpLetMatch n vars (fillExprHole vid t bindExp) (fillExprHole vid t inExp)+fillExprHole vid t (ExpLet i ty bindExp inExp) =+  ExpLet i ty (fillExprHole vid t bindExp) (fillExprHole vid t inExp)+fillExprHole vid t (ExpCaseMatch bindExp alts) =+  ExpCaseMatch (fillExprHole vid t bindExp) [ (c, vars, fillExprHole vid t expr)+                                            | (c, vars, expr) <- alts+                                            ]+fillExprHole _ _ t@ExpName{} = t+fillExprHole _ _ t@ExpVar{}  = t+

+ src/Language/Haskell/Exference/Core/ExpressionSimplify.hs view

@@ -0,0 +1,147 @@+module Language.Haskell.Exference.Core.ExpressionSimplify+  ( simplifyExpression+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.Expression++import Data.Function ( on )++++simplifyExpression :: Expression -> Expression+simplifyExpression = simplifyId . simplifyCompose . simplifyEta . simplifyLets++++simplifyLets :: Expression -> Expression+simplifyLets e@ExpVar{}       = e+simplifyLets e@ExpName{}      = e+simplifyLets (ExpLambda i ty e)  = ExpLambda i ty $ simplifyLets e+simplifyLets (ExpApply e1 e2) = ExpApply (simplifyLets e1) (simplifyLets e2)+simplifyLets e@ExpHole{}      = e+simplifyLets (ExpLetMatch name vids bindExp inExp) =+  ExpLetMatch name vids (simplifyLets bindExp) (simplifyLets inExp)+simplifyLets (ExpLet i ty bindExp inExp) = case countUses i inExp of+  0 -> simplifyLets inExp+  1 -> simplifyLets $ replaceVar i bindExp inExp+  _ -> ExpLet i ty (simplifyLets bindExp) (simplifyLets inExp)+simplifyLets (ExpCaseMatch bindExp alts) =+  ExpCaseMatch (simplifyLets bindExp) [ (c, vars, simplifyLets expr)+                                      | (c, vars, expr) <- alts+                                      ]++simplifyEta :: Expression -> Expression+simplifyEta e@ExpVar{}         = e+simplifyEta e@ExpName{}        = e+simplifyEta (ExpLambda i ty e) = simplifyEta' $ ExpLambda i ty $ simplifyEta e+simplifyEta (ExpApply e1 e2)   = ExpApply (simplifyEta e1) (simplifyEta e2)+simplifyEta e@ExpHole{}        = e+simplifyEta (ExpLetMatch name vids bindExp inExp) =+  ExpLetMatch name vids (simplifyEta bindExp) (simplifyEta inExp)+simplifyEta (ExpLet i ty bindExp inExp) =+  ExpLet i ty (simplifyEta bindExp) (simplifyEta inExp)+simplifyEta (ExpCaseMatch bindExp alts) =+  ExpCaseMatch (simplifyEta bindExp) [ (c, vars, simplifyEta expr)+                                     | (c, vars, expr) <- alts+                                     ]++simplifyEta' :: Expression -> Expression+simplifyEta' (ExpLambda i _ (ExpApply e1 (ExpVar j _)))+  | i==j && 0==countUses i e1 = e1+simplifyEta' e = e+++simplifyId :: Expression -> Expression+simplifyId e@ExpVar{}                 = e+simplifyId e@ExpName{}                = e+simplifyId e@(ExpLambda i _ (ExpVar j _))+  | i == j                            = ExpName (QualifiedName [] "id")+  | otherwise                         = e+simplifyId (ExpLambda i ty e)         = ExpLambda i ty $ simplifyId e+simplifyId (ExpApply e1 e2)           = ExpApply (simplifyId e1) (simplifyId e2)+simplifyId e@ExpHole{}                = e+simplifyId (ExpLetMatch name vids bindExp inExp)+                                      = ExpLetMatch name+                                                    vids+                                                    (simplifyId bindExp)+                                                    (simplifyId inExp)+simplifyId (ExpLet i ty bindExp inExp)   =+  ExpLet i ty (simplifyId bindExp) (simplifyId inExp)+simplifyId (ExpCaseMatch bindExp alts) =+  ExpCaseMatch (simplifyId bindExp) [ (c, vars, simplifyId expr)+                                    | (c, vars, expr) <- alts+                                    ]++simplifyCompose :: Expression -> Expression+simplifyCompose e@ExpVar{}         = e+simplifyCompose e@ExpName{}        = e+simplifyCompose (ExpLambda i ty e) = simplifyCompose' i ty [] e+simplifyCompose (ExpApply e1 e2)   = ExpApply (simplifyCompose e1) (simplifyCompose e2)+simplifyCompose e@ExpHole{}        = e+simplifyCompose (ExpLetMatch name vids bindExp inExp)+                                 = ExpLetMatch name+                                               vids+                                               (simplifyCompose bindExp)+                                               (simplifyCompose inExp)+simplifyCompose (ExpLet i ty bindExp inExp)+                                 = ExpLet i+                                          ty+                                          (simplifyCompose bindExp)+                                          (simplifyCompose inExp)+simplifyCompose (ExpCaseMatch bindExp alts)+                                 = ExpCaseMatch+                                     (simplifyCompose bindExp)+                                     [ (c, vars, simplifyCompose expr)+                                     | (c, vars, expr) <- alts+                                     ]++simplifyCompose' :: Int -> HsType -> [Expression] -> Expression -> Expression+simplifyCompose' i ty [] e@ExpVar{} = ExpLambda i ty e+simplifyCompose' i ty l e@(ExpVar j _)+  | i == j    = foldl1 (\e1 e2 -> ExpApply+                                    (ExpApply+                                      (ExpName (QualifiedName [] "(.)")) e2) e1)+                       l+  | otherwise = ExpLambda i ty $ foldl (flip ExpApply) e l+simplifyCompose' i ty l (ExpApply e1 e2)+  | countUses i e1==0 = simplifyCompose' i ty (simplifyCompose e1:l) e2+simplifyCompose' i ty l e = ExpLambda i ty+                          $ foldl (flip ExpApply) (simplifyCompose e) l++replaceVar :: TVarId -> Expression -> Expression -> Expression+replaceVar vid t orig@(ExpVar j _) | vid==j = t+                                   | otherwise = orig+replaceVar vid t (ExpLambda i ty e) = ExpLambda i ty $ replaceVar vid t e+replaceVar vid t (ExpApply e1 e2) = ExpApply (replaceVar vid t e1)+                                             (replaceVar vid t e2)+replaceVar vid t (ExpLetMatch n vars bindExp inExp) =+  ExpLetMatch n vars (replaceVar vid t bindExp) (replaceVar vid t inExp)+replaceVar vid t (ExpLet i ty bindExp inExp) =+  ExpLet i ty (replaceVar vid t bindExp) (replaceVar vid t inExp)+replaceVar vid t (ExpCaseMatch bindExp alts) =+  ExpCaseMatch (replaceVar vid t bindExp) [ (c, vars, replaceVar vid t expr)+                                          | (c, vars, expr) <- alts+                                          ]+replaceVar _ _ t@(ExpName _) = t+replaceVar _ _ t@(ExpHole _) = t+++countUses :: TVarId -> Expression -> Int+countUses i (ExpVar j _) | i==j           = 1+                         | otherwise      = 0+countUses _ ExpName{}                     = 0+countUses i (ExpLambda j _ e) | i==j      = 0+                              | otherwise = countUses i e+countUses i (ExpApply e1 e2)              = ((+) `on` countUses i) e1 e2+countUses _ ExpHole{}                     = 0+countUses i (ExpLetMatch _ _ bindExp inExp) = ((+) `on` countUses i) bindExp inExp+countUses i (ExpLet _ _ bindExp inExp)    = ((+) `on` countUses i) bindExp inExp+countUses i (ExpCaseMatch bindExp alts)   = sum $ countUses i bindExp+                                                : [ countUses i expr+                                                  | (_, _, expr) <- alts+                                                  ]+

+ src/Language/Haskell/Exference/Core/FunctionBinding.hs view

@@ -0,0 +1,24 @@+module Language.Haskell.Exference.Core.FunctionBinding+  ( FunctionBinding+  , DeconstructorBinding+  , EnvDictionary+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.Expression++++type FunctionBinding = (HsType, QualifiedName, Float, [HsConstraint], [HsType])+                      -- input-type, name, rating, contraints, result-types++type DeconstructorBinding = (HsType, [(QualifiedName, [HsType])], Bool)+                      -- input-type, (name, result-types)s, is-recursive++type EnvDictionary = ( [FunctionBinding]+                     , [DeconstructorBinding]+                     , StaticClassEnv+                     )

+ src/Language/Haskell/Exference/Core/Internal/ConstraintSolver.hs view

@@ -0,0 +1,64 @@+{-# LANGUAGE MonadComprehensions #-}++module Language.Haskell.Exference.Core.Internal.ConstraintSolver+  ( isPossible+  , filterUnresolved+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.Core.Internal.Unify++import qualified Data.Set as S+import Control.Monad ( mplus, guard, join )+import Control.Applicative ( (<|>), (<$>), liftA2 )+import Data.Foldable ( asum )+import Data.Maybe ( fromMaybe )+import Data.Traversable ( traverse )++import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IntMap++import Debug.Trace++++-- returns Nothing if one of the constraints is refutable+-- otherwise Just a list of open constraints (that could neither be+-- solved nor refuted).+isPossible :: QueryClassEnv -> [HsConstraint] -> Maybe [HsConstraint]+isPossible = checkPossibleGeneric (Just . return) (const Nothing)++-- returns Nothing if any of the constraints contains variables+-- (as variables cannot be proven).+-- Otherwise returns the list of constraints that cannot be proven,+-- and removing all those that can be proven.+filterUnresolved :: QueryClassEnv -> [HsConstraint] -> Maybe [HsConstraint]+filterUnresolved = checkPossibleGeneric (const Nothing) (Just . return)++checkPossibleGeneric :: (HsConstraint -> Maybe [HsConstraint])+                     -> (HsConstraint -> Maybe [HsConstraint])+                     -> QueryClassEnv+                     -> [HsConstraint]+                     -> Maybe [HsConstraint]+checkPossibleGeneric containsVarsResult otherwiseResult qClassEnv = fmap concat . traverse g where+  g c = if constraintContainsVariables c+    then containsVarsResult c+    else possibleFromGiven c <|> possibleFromInstance c <|> otherwiseResult c+  possibleFromGiven :: HsConstraint -> Maybe [HsConstraint]+  possibleFromGiven c = [ [] | S.member c $ qClassEnv_inflatedConstraints qClassEnv ]+  possibleFromInstance :: HsConstraint -> Maybe [HsConstraint]+  possibleFromInstance c = asum $ f <$> is where+    (HsConstraint cclass cparams) = c+    is = M.findWithDefault []+                           (tclass_name cclass)+                           ( sClassEnv_instances+                             $ qClassEnv_env qClassEnv )+    f (HsInstance instConstrs _iclass instParams) = do+      substs <- unifyRightEqs $ zipWith TypeEq cparams instParams+      checkPossibleGeneric containsVarsResult otherwiseResult+        qClassEnv+        (map (snd . constraintApplySubsts substs) instConstrs)

+ src/Language/Haskell/Exference/Core/Internal/Exference.hs view

@@ -0,0 +1,648 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+++module Language.Haskell.Exference.Core.Internal.Exference+  ( findExpressions+  , ExferenceHeuristicsConfig (..)+  , ExferenceInput (..)+  , ExferenceOutputElement+  , ExferenceChunkElement (..)+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.Core.Expression+import Language.Haskell.Exference.Core.ExferenceStats+import Language.Haskell.Exference.Core.FunctionBinding+import Language.Haskell.Exference.Core.SearchTree+import Language.Haskell.Exference.Core.Internal.Unify+import Language.Haskell.Exference.Core.Internal.ConstraintSolver+import Language.Haskell.Exference.Core.Internal.ExferenceNode+import Language.Haskell.Exference.Core.Internal.ExferenceNodeBuilder++import Control.Monad.Trans.MultiState++import qualified Data.PQueue.Prio.Max as Q+import qualified Data.Map as M+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Set as S+import qualified Data.Vector as V+import qualified Data.Sequence as Seq++import Control.DeepSeq.Generics+import System.Mem.StableName ( StableName, makeStableName )+import System.IO.Unsafe ( unsafePerformIO )++import Data.Maybe ( maybeToList, listToMaybe, fromMaybe, catMaybes, mapMaybe, isNothing )+import Control.Arrow ( first, second, (***), (&&&) )+import Control.Monad ( when, unless, guard, mzero, replicateM+                     , replicateM_, forM, join, forM_, liftM )+import Control.Applicative ( (<$>), (<*>), (*>), (<|>), empty )+import Data.List ( partition, sortBy, groupBy, unfoldr, intercalate )+import Data.Ord ( comparing )+import Data.Function ( on )+import Data.Functor ( ($>) )+import Data.Monoid ( Any(..), Endo(..), Sum(..) )+import Data.Foldable ( foldMap, sum, asum, traverse_ )+import Control.Monad.Morph ( lift )+import Data.Typeable ( Typeable )+import Control.Lens+import Control.Monad.State ( StateT(..), State, gets, execStateT, get, runStateT, mapStateT )+import Control.Monad.State ( MonadState )++-- import Control.Concurrent.Chan+import Control.Concurrent ( forkIO )+import qualified GHC.Conc.Sync++import Data.Data ( Data )++-- import Data.DeriveTH+-- import Debug.Hood.Observe+import Debug.Trace++import Prelude hiding ( sum )++++data ExferenceHeuristicsConfig = ExferenceHeuristicsConfig+  { heuristics_goalVar                :: Float+  , heuristics_goalCons               :: Float+  , heuristics_goalArrow              :: Float+  , heuristics_goalApp                :: Float+  , heuristics_stepProvidedGood       :: Float+  , heuristics_stepProvidedBad        :: Float+  , heuristics_stepEnvGood            :: Float+  , heuristics_stepEnvBad             :: Float+  , heuristics_tempUnusedVarPenalty   :: Float+  , heuristics_tempMultiVarUsePenalty :: Float+  , heuristics_functionGoalTransform  :: Float+  , heuristics_unusedVar              :: Float+  , heuristics_solutionLength         :: Float+  }+  deriving (Show, Data, Typeable)++data ExferenceInput = ExferenceInput+  { input_goalType    :: HsType                 -- ^ try to find a expression+                                                -- of this type+  , input_envFuncs    :: [FunctionBinding]      -- ^ the list of functions+                                                -- that may be used+  , input_envDeconsS  :: [DeconstructorBinding] -- ^ the list of deconstructors+                                                -- that may be used for pattern+                                                -- matching+  , input_envClasses  :: StaticClassEnv+  , input_allowUnused :: Bool                   -- ^ if false, forbid solutions+                                                -- where any bind is unused+  , input_allowConstraints :: Bool              -- ^ if true, allow solutions+                                                -- that have unproven+                                                -- constraints remaining.+  , input_allowConstraintsStopStep :: Int       -- ^ stop ignoring+                                                -- tc-constraints after this+                                                -- step to have some chance to+                                                -- find some solution.+  , input_multiPM     :: Bool                   -- ^ pattern match on+                                                -- multi-constructor data types+                                                -- if true. serverly increases+                                                -- search space (decreases+                                                -- performance).+  , input_maxSteps    :: Int                    -- ^ the maximum number of+                                                -- steps to perform (otherwise+                                                -- would not terminate if+                                                -- there were no (more)+                                                -- solutions).+  , input_memoryLimit :: Maybe Int              -- ^ allows to limit memory+                                                -- usage. no effect if Nothing;+                                                -- for (Just x), memory usage+                                                -- scales with x.+                                                -- Lower memory usage discards+                                                -- states (and, thus, potential+                                                -- solutions).+  , input_heuristicsConfig :: ExferenceHeuristicsConfig+  }+  deriving (Show, Data, Typeable)++type ExferenceOutputElement = (Expression, [HsConstraint], ExferenceStats)+data ExferenceChunkElement = ExferenceChunkElement+  { chunkBindingUsages :: BindingUsages+#if BUILD_SEARCH_TREE+  , chunkSearchTree :: SearchTree+#endif+  , chunkElements :: [ExferenceOutputElement]+  }++type RatedNodes = Q.MaxPQueue Float SearchNode+data FindExpressionsState = FindExpressionsState+  { _findExpressionsStateN :: Int    -- number of steps already performed+  , _findExpressionsStateWorst :: Float  -- worst rating of state in pqueue+  , _findExpressionsStateBindingUsages :: BindingUsages+#if BUILD_SEARCH_TREE+  , _findExpressionsStateSt :: SearchTreeBuilder (StableName SearchNode)+#endif+  , _findExpressionsStateStates :: RatedNodes -- pqueue+  }+makeFields ''FindExpressionsState++-- Entry-point and main function of the algorithm.+-- Takes input, produces list of outputs. Output is basically a+-- [[Solution]], plus some statistics and stuff.+-- Nested list to allow executing n steps even when no solutions are found+-- (e.g. you take 1000, and get only []'s).+--+-- Basic implementation idea: We traverse a search tree. A step (`stateStep`+-- function) evaluates one node, and returns+-- a) new search nodes b) potential solutions.+-- findExpressions does the following stuff:+--   - determine what searchnode to use next (using a priority queue)+--   - call stateStep repeatedly+--   - convert stuff+--   - consider some special abort conditions+findExpressions :: ExferenceInput+                -> [ExferenceChunkElement]+findExpressions (ExferenceInput rawType+                                funcs+                                deconss'+                                sClassEnv+                                allowUnused+                                allowConstraints+                                _allowConstraintsStopStep+                                multiPM+                                maxSteps -- since we output a [[x]],+                                         -- this would not really be+                                         -- necessary anymore. but+                                         -- we also use it for calculating+                                         -- memory limit stuff, and it is+                                         -- not worth the refactor atm.+                                memLimit+                                heuristics) =+  take maxSteps $ unfoldr helper rootFindExpressionState+ where+  rootFindExpressionState = FindExpressionsState+    0+    0+    M.empty+#if BUILD_SEARCH_TREE+    (initialSearchTreeBuilder initNodeName (ExpHole 0))+#endif+    (Q.singleton 0.0 rootSearchNode)+  t = forallify rawType+  rootSearchNode = SearchNode+    { _searchNodeGoals           = (Seq.singleton (VarBinding 0 t, 0))+    , _searchNodeConstraintGoals = []+    , _searchNodeProvidedScopes  = initialScopes+    , _searchNodeVarUses         = IntMap.empty+    , _searchNodeFunctions       = (V.fromList funcs) -- TODO: lift this further up?+    , _searchNodeDeconss         = deconss'+    , _searchNodeQueryClassEnv   = (mkQueryClassEnv sClassEnv [])+    , _searchNodeExpression      = (ExpHole 0)+    , _searchNodeNextVarId       = 1 -- TODO: change to 0?+    , _searchNodeMaxTVarId       = (largestId t)+    , _searchNodeNextNVarId      = 0+    , _searchNodeDepth           = 0.0+#if LINK_NODES+    , _searchNodePreviousNode    = Nothing+#endif+    , _searchNodeLastStepReason  = ""+    , _searchNodeLastStepBinding = Nothing+    }+#if BUILD_SEARCH_TREE+  initNodeName = unsafePerformIO $ makeStableName $! rootSearchNode+#endif+  transformSolutions :: [SearchNode] -> FindExpressionsState -> ExferenceChunkElement+  transformSolutions potentialSolutions (FindExpressionsState+      n'+      _+      newBindingUsages+#if BUILD_SEARCH_TREE+      newSearchTreeBuilder+#endif+      newNodes+    ) = ExferenceChunkElement+      newBindingUsages+#if BUILD_SEARCH_TREE+      (buildSearchTree newSearchTreeBuilder initNodeName)+#endif+      [ (e, remainingConstraints, ExferenceStats n' d $ Q.size newNodes)+      | solution <- potentialSolutions+      , let contxt = view queryClassEnv solution+      , remainingConstraints <- maybeToList+                              $ filterUnresolved contxt+                              $ view constraintGoals solution+        -- if allowConstraints, unresolved constraints are allowed;+        -- otherwise we discard this solution.+      , allowConstraints || null remainingConstraints+      , let unusedVarCount = getUnusedVarCount solution+        -- similarly:+        -- if allowUnused, there may be unused variables in the+        -- output. Otherwise the solution is discarded.+      , allowUnused || unusedVarCount==0+      , let e = -- trace (showNodeDevelopment solution) $+                view expression solution+      , let d = view depth solution+              + ( heuristics_unusedVar heuristics+                * fromIntegral unusedVarCount+                )+              -- + ( heuristics_solutionLength heuristics+              --   * fromIntegral (length $ show e)<+              --   )+      ]+  helper :: FindExpressionsState -> Maybe (ExferenceChunkElement, FindExpressionsState)+  helper = runStateT $ do+    s <- zoom states $ StateT Q.maxView+    qsize <- uses states Q.size+    n' <- n <<+= 1+    worst' <- use worst+    let+      -- actual work happens in stateStep+      rNodes = (`execStateT` s)+        $ stateStep multiPM+                    allowConstraints+                    heuristics+      -- distinguish "finished"/"unfinished" sub-SearchNodes+      (potentialSolutions, futures) = partition (views goals Seq.null) rNodes+      -- this cutoff is somewhat arbitrary, and can, theoretically,+      -- distort the order of the results (i.e.: lead to results being+      -- omitted).+      filteredNew = fromMaybe id+        [ filter ((>cutoff) . fst)+        | qsize > maxSteps+        , mmax <- memLimit+        , let cutoff = worst' * fromIntegral mmax+                              / fromIntegral qsize+        ]+        [ ( rateNode heuristics newS + 4.5*f (fromIntegral n')+          , newS)+        | newS <- futures+        , let f :: Float -> Float+              f x | x > 900 = 0.0+                  | otherwise = let k = 1.111e-3*x+                                 in 1 + 2*k**3 - 3*k**2+        ]+    bindingUsages . maybe ignored at (view lastStepBinding s) . non 0 += 1+    states %= Q.union (Q.fromList filteredNew)+#if BUILD_SEARCH_TREE+    st %=+      ( ((++) [ unsafePerformIO $ do+               n1 <- makeStableName $! ns+               n2 <- makeStableName $! s+               return (n1,n2,view expression ns)+             | ns<-rNodes+             ])+      ***+        ((:) (unsafePerformIO (makeStableName $! s)))+      )+#endif+    worst %= minimum . (: map fst filteredNew)+    gets $ transformSolutions potentialSolutions++rateNode :: ExferenceHeuristicsConfig -> SearchNode -> Float+rateNode h s = 0.0 - rateGoals h (view goals s) - view depth s + rateUsage h s+ -- + 0.6 * rateScopes (view providedScopes s)++rateGoals :: ExferenceHeuristicsConfig -> Seq.Seq TGoal -> Float+rateGoals h = sum . fmap rateGoal+  where+    rateGoal (VarBinding _ t,_) = tComplexity t+    -- TODO: actually measure performance with different values,+    --       use derived values instead of (arbitrarily) chosen ones.+    tComplexity (TypeVar _)         = heuristics_goalVar h+    tComplexity (TypeConstant _)    = heuristics_goalCons h -- TODO different heuristic?+    tComplexity (TypeCons _)        = heuristics_goalCons h+    tComplexity (TypeArrow t1 t2)   = heuristics_goalArrow h + tComplexity t1 + tComplexity t2+    tComplexity (TypeApp   t1 t2)   = heuristics_goalApp h   + tComplexity t1 + tComplexity t2+    tComplexity (TypeForall _ _ t1) = tComplexity t1++-- using this rating had bad effect on ordering; not used anymore+{-+rateScopes :: Scopes -> Float+rateScopes (Scopes _ sMap) = alaf Sum foldMap f sMap where+    f (Scope binds _) = fromIntegral (length binds)+-}++rateUsage :: ExferenceHeuristicsConfig -> SearchNode -> Float+rateUsage h = sumOf $ varUses . folded . to f where+  f :: Int -> Float+  f 0 = - heuristics_tempUnusedVarPenalty h+  f 1 = 0+  f k = - fromIntegral (k-1) * heuristics_tempMultiVarUsePenalty h++getUnusedVarCount :: SearchNode -> Int+getUnusedVarCount s = length $ filter (==0) $ s ^.. varUses . folded++-- Take one SearchNode, return some amount of sub-SearchNodes. Some of the+-- returned SearchNodes may in fact be (potential) solutions that do not+-- require further evaluation.+--+-- Basic implementation idea:+-- Take the first goal for this SearchNode. Its type determines what the next+-- step is (and which sub-function to use).+stateStep :: Bool+          -> Bool+          -> ExferenceHeuristicsConfig+          -> StateT SearchNode [] ()+stateStep multiPM allowConstrs h = do++  do+    _s <- get+    id+      -- $ trace (showSearchNode' qNameIndex _s ++ " " ++ show (rateNode h _s))+      $ return ()+    -- trace (unlines [ show (view  depth _s)+    --                , show (view  goals _s)+    --                , show (view  constraintGoals _s)+    --                , show (view  providedScopes _s)+    --                , showExpression (view  expression                _s)+    --                , view lastStepReason _s+    --                ]) $ return ()++  -- This paragraph is evil, and hopefully temporary. (Scoping issues make it necessary.)+  contxt <- use queryClassEnv+  constraintGoals' <- use constraintGoals++  ((VarBinding var goalType, scopeId) Seq.:< gr) <- Seq.viewl <$> use goals+  goals .= gr++  guard . (<= 200.0) =<< use depth++  let+    -- if type is TypeArrow, transform to lambda expression.+    arrowStep :: MonadState SearchNode m => HsType -> [VarBinding] -> m ()+    arrowStep g ts+      -- descend until no more TypeArrows, accumulating what is seen.+      | TypeArrow t1 t2 <- g = do+          nextId <- builderAllocVar+          arrowStep t2 (VarBinding nextId t1 : ts)+      -- finally, do the goal/expression transformation.+      | otherwise = do+          nextId <- nextVarId <<+= 1+          newScopeId <- builderAddScope scopeId+          expression %= fillExprHole var+            (foldl (\e (VarBinding v ty) -> ExpLambda v ty e) (ExpHole nextId) ts)+          depth += heuristics_functionGoalTransform h+          builderSetReason "function goal transform"+          lastStepBinding .= Nothing+          -- for each parameter introduced in the lambda-expression above,+          -- it may be possible to pattern-match. and pattern-matching+          -- may cause duplication of the goals (e.g. for the different cases+          -- in the pattern match).+          additionalGoals <- addScopePatternMatch multiPM g nextId newScopeId+            $ map splitBinding+            $ reverse ts+          goals <>= Seq.fromList additionalGoals++    -- if type is TypeForall, fix the forall-variables, i.e. invent a fresh+    -- set of constants that replace the relevant forall-variables.+    forallStep :: MonadState SearchNode m => [TVarId] -> [HsConstraint] -> HsType -> m ()+    forallStep vs cs t = do+      dataIds <- mapM (const $ nextNVarId <<+= 1) vs+      depth += heuristics_functionGoalTransform h -- TODO: different heuristic?+      builderSetReason "forall-type goal transformation"+      lastStepBinding .= Nothing+      let substs = IntMap.fromList $ zip vs $ TypeConstant <$> dataIds+      goals %= ((VarBinding var $ snd $ applySubsts substs t, scopeId) <|)+      queryClassEnv %= addQueryClassEnv (snd . constraintApplySubsts substs <$> cs)+    -- try to resolve the goal by looking at the parameters in scope, i.e.+    -- the parameters accumulated by building the expression so far.+    -- e.g. for (\x -> (_ :: Int)), the goal can be filled by `x` if+    -- `x :: Int`.++    byProvided :: StateT SearchNode [] ()+    byProvided = do+      (provId, provT, provPs, forallTypes, constraints)+        <- lift =<< uses providedScopes (scopeGetAllBindings scopeId)+      offset <- uses maxTVarId (+1)+      let+        incF        = incVarIds (+offset)+        ss          = IntMap.fromList $ zip forallTypes (incF . TypeVar <$> forallTypes)+        provType    = snd $ applySubsts ss provT+        provConstrs = S.toList $ S.union+          (qClassEnv_constraints contxt)+          (S.fromList (snd . constraintApplySubsts ss <$> constraints))+      mapStateT maybeToList $ byGenericUnify+        (Right (provId, foldr TypeArrow provT provPs))+        provType+        provConstrs+        (snd . applySubsts ss <$> provPs)+        (heuristics_stepProvidedGood h)+        (heuristics_stepProvidedBad h)+        ("inserting given value " ++ show provId ++ "::" ++ show provT)+        (unify goalType provType)++    -- try to resolve the goal by looking at functions from the environment.+    byFunctionSimple :: StateT SearchNode [] ()+    byFunctionSimple = do+      (funcR, funcId, funcRating, funcConstrs, funcParams)+        <- lift =<< uses functions V.toList+      offset <- uses maxTVarId (+1)+      let+        incF     = incVarIds (+offset)+        provType = incF funcR+      mapStateT maybeToList $ byGenericUnify+        (Left funcId)+        provType+        (map (constraintMapTypes incF) funcConstrs)+        (map incF funcParams)+        (heuristics_stepEnvGood h + funcRating)+        (heuristics_stepEnvBad h + funcRating)+        ("applying function " ++ show funcId)+        (unifyOffset goalType (HsTypeOffset funcR offset))++    -- on code for byProvided and byFunctionSimple+    byGenericUnify :: Either QualifiedName (TVarId, HsType)+                   -> HsType+                   -> [HsConstraint]+                   -> [HsType]+                   -> Float+                   -> Float+                   -> String+                   -> Maybe (Substs, Substs)+                   -> StateT SearchNode Maybe ()+    byGenericUnify applier+                   provided+                   provConstrs+                   dependencies+                   depthModMatch+                   depthModNoMatch+                   reasonPart+      = maybe noUnify $ uncurry byUnified+     where+      applierl = applier ^? _Left+      applierr = applier ^? _Right+      coreExp = either ExpName (uncurry ExpVar) applier++      noUnify :: StateT SearchNode Maybe ()+      noUnify = case dependencies of+        [] -> mzero -- we can't (randomly) partially apply a non-function+        (d:ds) -> do+          vResult <- builderAllocVar+          vParam  <- nextVarId <<+= 1+          expression %= fillExprHole var (ExpLet+            vResult+            provided+            (ExpApply coreExp $ ExpHole vParam)+            (ExpHole var))+          goals %= ((VarBinding vParam d, scopeId) <|)+          newScopeId <- builderAddScope scopeId+          constraintGoals <>= provConstrs+          traverse_ (\r -> varUses . singular (ix $ fst r) += 1) applierr+          maxTVarId %= max (maximum $ map largestId dependencies)+          depth += depthModNoMatch+          builderSetReason $ "randomly trying to apply function "+                            ++ showExpression coreExp+          additionalGoals <- addScopePatternMatch+            multiPM+            goalType+            var+            newScopeId+            (let (r,ps,fs,cs) = splitArrowResultParams provided+              in [(vResult, r, ds++ps, fs, cs)])+          goals <>= Seq.fromList additionalGoals++      byUnified :: Substs -> Substs -> StateT SearchNode Maybe ()+      byUnified goalSS provSS = do+        let allSS = IntMap.union goalSS provSS+            substs = case applier of+              Left _  -> goalSS+              Right _ -> allSS+            (applied1, constrs1) = mapM (constraintApplySubsts substs)+                                        constraintGoals'+            constrs2 = map (snd . constraintApplySubsts provSS)+              provConstrs+        newConstraints <- lift $ if allowConstrs+          then Just $ constrs1 ++ constrs2+          else if getAny applied1+            then                   isPossible contxt (constrs1 ++ constrs2)+            else (constrs1 ++) <$> isPossible contxt constrs2+        let paramN = length dependencies+        vars <- replicateM paramN $ nextVarId <<+= 1+        let newGoals = mkGoals scopeId $ zipWith VarBinding vars dependencies+        goals <>= Seq.fromList+          (ala Endo foldMap (applierl $> goalApplySubst provSS)+          <$> newGoals)+        builderApplySubst substs+        expression %= fillExprHole var+          (foldl ExpApply coreExp (map ExpHole vars))+        traverse_ (\r -> varUses . singular (ix $ fst r) += 1) applierr+        constraintGoals .= newConstraints+        maxTVarId %= max (maximum+          $ largestSubstsId goalSS : map largestId dependencies)+        depth += depthModMatch+        let substsTxt   = show (IntMap.union goalSS provSS)+                          ++ " unifies "+                          ++ show goalType+                          ++ " and "+                          ++ show provided+        let provableTxt = "constraints (" ++ show (constrs1++constrs2)+                                          ++ ") are provable"+        builderSetReason $ reasonPart ++ ", because " ++ substsTxt+                          ++ " and because " ++ provableTxt+        lastStepBinding .= fmap show applierl++  case goalType of+    TypeArrow _ _ -> arrowStep goalType []+    TypeForall is cs t -> forallStep is cs t+    _ -> byProvided <|> byFunctionSimple+++{-# INLINE addScopePatternMatch #-}+-- Insert pattern-matching on newly introduced VarPBindings where+-- possible/necessary. Note that this also effectively transforms a goal+-- (into potentially multiple goals), as goal id + HsType + ScopeId = TGoal.+-- So the input describes one single TGoal.+-- TGoals are duplicated when the pattern-matching involves more than one case,+-- as the goals for different cases are distinct because their scopes are+-- modified when new bindings are added by the pattern-matching.+addScopePatternMatch :: MonadState SearchNode m+                     => Bool -- should p-m on anything but newtypes?+                     -> HsType -- the current goal (should be returned in one+                               --  form or another)+                     -> Int    -- goal id (hole id)+                     -> ScopeId -- scope for this goal+                     -> [VarPBinding]+                     -> m [TGoal]+addScopePatternMatch multiPM goalType vid sid bindings = case bindings of+  []                                    -> return [(VarBinding vid goalType, sid)]+  (b@(v,vtResult,vtParams,_,_):bindingRest) -> do+    offset <- builderGetTVarOffset+    let incF = incVarIds (+offset)+    let expVar = ExpVar v (foldr TypeArrow vtResult vtParams)+    providedScopes %= scopesAddPBinding sid b+    let defaultHandleRest = addScopePatternMatch multiPM goalType vid sid bindingRest+    case vtResult of+      TypeVar {}    -> defaultHandleRest -- dont pattern-match on variables, even if it unifies+      TypeArrow {}  ->+        error $ "addScopePatternMatch: TypeArrow: " ++ show vtResult  -- should never happen, given a pbinding..+      TypeForall {} ->+        error $ "addScopePatternMatch: TypeForall (RankNTypes not yet implemented)" -- todo when we do RankNTypes+                ++ show vtResult+      _ | not $ null vtParams -> defaultHandleRest+        | otherwise -> fromMaybe defaultHandleRest . asum . map mapFunc =<< use deconss+         where+          mapFunc :: MonadState SearchNode m => DeconstructorBinding -> Maybe (m [TGoal])+          mapFunc (matchParam, [(matchId, matchRs)], False) = let+            resultTypes = map incF matchRs+            unifyResult = unifyRightOffset vtResult+                                           (HsTypeOffset matchParam offset)+            -- inputType = incF matchParam+            mapFunc1 substs = do -- m+              vars <- replicateM (length matchRs) builderAllocVar+              varUses . singular (ix v) += 1+              builderAppendReason $ "pattern matching on " ++ showVar v+                ++ "\n" ++ intercalate "\n" +                  [ show bindings+                  , show offset+                  , show (matchParam, matchId, matchRs)+                  , show (vtResult, matchParam, offset)+                  , show unifyResult+                  ]+              let newProvTypes = map (snd . applySubsts substs) resultTypes+                  newBinds = zipWith (\x y -> splitBinding (VarBinding x y))+                                     vars+                                     newProvTypes+                  expr = ExpLetMatch matchId+                                     (zip vars matchRs)+                                     expVar+                                     (ExpHole vid)+              expression %= fillExprHole vid expr+              unless (null matchRs) $+                maxTVarId %= max (maximum $ map largestId newProvTypes)+              addScopePatternMatch multiPM+                                   goalType+                                   vid+                                   sid+                                   (reverse newBinds ++ bindingRest)+            in liftM mapFunc1 unifyResult+          mapFunc (matchParam, matchers@(_:_), False) | multiPM = let+            unifyResult = unifyRightOffset vtResult+                                           (HsTypeOffset matchParam offset)+            -- inputType = incF matchParam+            mapFunc2 substs = do -- m+              mData <- matchers `forM` \(matchId, matchRs) -> do -- m+                newSid <- builderAddScope sid+                let resultTypes = map incF matchRs+                vars <- replicateM (length matchRs) builderAllocVar+                varUses . singular (ix v) += 1+                newVid <- nextVarId <<+= 1+                let newProvTypes = map (snd . applySubsts substs) resultTypes+                    newBinds = zipWith (\x y -> splitBinding (VarBinding x y)) vars newProvTypes+                unless (null matchRs) $+                  maxTVarId %= max (maximum $ map largestId newProvTypes)+                return ( (matchId, zip vars newProvTypes, ExpHole newVid)+                       , (newVid, reverse newBinds, newSid) )+              builderAppendReason $ "pattern matching on " ++ showVar v+              expression %= fillExprHole vid (ExpCaseMatch expVar $ map fst mData)+              liftM concat $ map snd mData `forM` \(newVid, newBinds, newSid) ->+                addScopePatternMatch multiPM goalType newVid newSid (newBinds++bindingRest)+            in liftM mapFunc2 unifyResult+          mapFunc _ = Nothing -- TODO: decons for recursive data types+  -- where+  --  (<&>) = flip (<$>)

+ src/Language/Haskell/Exference/Core/Internal/ExferenceNode.hs view

@@ -0,0 +1,348 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+++module Language.Haskell.Exference.Core.Internal.ExferenceNode+  ( SearchNode (..)+  , TGoal+  , Scopes (..)+  , Scope (..)+  , ScopeId+  , VarPBinding+  , VarBinding (..)+  , VarUsageMap+  , varBindingApplySubsts+  , varPBindingApplySubsts+  , goalApplySubst+  , showNodeDevelopment+  , scopesApplySubsts+  , mkGoals+  , addScope+  , scopeGetAllBindings+  , scopesAddPBinding+  , splitBinding+  , addNewScopeGoal+  , initialScopes+  , addGoalProvided -- unused atm+  , showSearchNode+  -- SearchNode lenses+  , HasGoals (..)+  , HasConstraintGoals (..)+  , HasProvidedScopes (..)+  , HasVarUses (..)+  , HasFunctions (..)+  , HasDeconss (..)+  , HasQueryClassEnv (..)+  , HasExpression (..)+  , HasNextVarId (..)+  , HasMaxTVarId (..)+  , HasNextNVarId (..)+  , HasDepth (..)+#if LINK_NODES  +  , HasPreviousNode (..)+#endif+  , HasLastStepReason (..)+  , HasLastStepBinding (..)+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.Core.Expression+import Language.Haskell.Exference.Core.ExferenceStats+import Language.Haskell.Exference.Core.FunctionBinding++import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Vector as V+import Data.Sequence+import Data.Foldable ( toList )+import Data.Functor.Identity ( runIdentity )++import Text.PrettyPrint++import Control.Arrow ( first, second, (***) )++import Control.DeepSeq.Generics+import Control.DeepSeq+import GHC.Generics+import Control.Lens.TH ( makeFields )++import Control.Monad.Trans.MultiRWS+import Control.Monad.Trans.MultiState ( runMultiStateTNil )+import Data.HList.ContainsType++-- import Debug.Hood.Observe++import Data.List ( intercalate )++++data VarBinding = VarBinding {-# UNPACK #-} !TVarId HsType+ deriving (Generic)+type VarPBinding = (TVarId, HsType, [HsType], [TVarId], [HsConstraint])+                -- var, result, params, forallTypes, constraints+++instance Show VarBinding where+  show (VarBinding vid ty) = showVar vid ++ " :-> " ++ show ty++varBindingApplySubsts :: Substs -> VarBinding -> VarBinding+varBindingApplySubsts substs (VarBinding v t) =+  VarBinding v (snd $ applySubsts substs t)++varPBindingApplySubsts :: Substs -> VarPBinding -> VarPBinding+varPBindingApplySubsts ss (v,rt,pt,fvs,cs) =+  let+    relevantSS = foldr IntMap.delete ss fvs+    (newResult, params, newForalls, newCs) = splitArrowResultParams+                                           $ snd+                                           $ applySubsts relevantSS rt+  in+  ( v+  , newResult+  , map (snd . applySubsts relevantSS) pt ++ params+  , newForalls ++ fvs+  , cs ++ newCs+  )++type ScopeId = Int++data Scope = Scope [VarPBinding] [ScopeId]+            -- scope bindings,   superscopes+  deriving Generic+data Scopes = Scopes ScopeId (IntMap.IntMap Scope)+  deriving Generic+              -- next id     scopes++instance Show Scope where+  show (Scope bindings sids) = "Scope " ++ show bindings ++ " " ++ show sids+instance Show Scopes where+  show (Scopes _sid intmap) = "Scopes\n" ++ intercalate ("\n") (fmap ("  " ++) $ fmap show $ IntMap.toAscList intmap)++initialScopes :: Scopes+initialScopes = Scopes 1 (IntMap.singleton 0 $ Scope [] [])++scopeGetAllBindings :: Int -> Scopes -> [VarPBinding]+scopeGetAllBindings sid ss@(Scopes _ scopeMap) =+  case IntMap.lookup sid scopeMap of+    Nothing -> []+    Just (Scope binds ids) -> binds ++ concatMap (`scopeGetAllBindings` ss) ids++scopesApplySubsts :: Substs -> Scopes -> Scopes+scopesApplySubsts substs (Scopes i scopeMap) = Scopes i $ IntMap.map scopeF scopeMap+  where+    scopeF (Scope binds ids) = Scope (map bindF binds) ids+    bindF = varPBindingApplySubsts substs++{-+scopesAddBinding :: ScopeId -> VarBinding -> Scopes -> Scopes+scopesAddBinding sid binding scopes =+  scopesAddPBinding sid (splitBinding binding) scopes+-}++scopesAddPBinding :: ScopeId -> VarPBinding -> Scopes -> Scopes+scopesAddPBinding sid binding (Scopes nid sMap) = Scopes nid newMap+  where+    newMap = IntMap.adjust addBinding sid sMap+    addBinding :: Scope -> Scope+    addBinding (Scope vbinds ids) = Scope (binding:vbinds) ids++addScope :: ScopeId -> Scopes -> (ScopeId, Scopes)+addScope parent (Scopes nid sMap) = (nid, Scopes (nid+1) newMap)+  where+    newMap   = IntMap.insert nid newScope sMap+    newScope = Scope [] [parent]++type VarUsageMap = IntMap.IntMap Int++type TGoal = (VarBinding, ScopeId)+           -- goal,    id of innermost scope available++goalApplySubst :: Substs -> TGoal -> TGoal+goalApplySubst ss | IntMap.null ss = id+                  | otherwise      = first (varBindingApplySubsts ss)++-- takes a new goal data, and a new set of provided stuff, and+-- returns some actual goal/newScope pair+addGoalProvided :: ScopeId+                -> VarBinding   -- goal binding+                -> [VarBinding] -- new-given-bindings+                -> Scopes+                -> (TGoal, Scopes)+addGoalProvided sid goalBind givenBinds (Scopes nid sMap) =+    ((goalBind, nid),Scopes (nid+1) newMap)+  where+    newMap = IntMap.insert nid (Scope transformedBinds [sid]) sMap+    transformedBinds = map splitBinding givenBinds++addNewScopeGoal :: ScopeId -> VarBinding -> Scopes -> (TGoal, ScopeId, Scopes)+addNewScopeGoal sid goalBind (Scopes nid sMap) =+    ((goalBind, nid), nid, Scopes (nid+1) newMap)+  where+    newMap = IntMap.insert nid (Scope [] [sid]) sMap++mkGoals :: ScopeId+        -> [VarBinding]+        -> [TGoal]+mkGoals sid vbinds = [(b,sid)|b<-vbinds]++data SearchNode = SearchNode+  { _searchNodeGoals           :: Seq TGoal+  , _searchNodeConstraintGoals :: [HsConstraint]+  , _searchNodeProvidedScopes  :: Scopes+  , _searchNodeVarUses         :: VarUsageMap+  , _searchNodeFunctions       :: V.Vector FunctionBinding+  , _searchNodeDeconss         :: [DeconstructorBinding]+  , _searchNodeQueryClassEnv   :: QueryClassEnv+  , _searchNodeExpression      :: Expression+  , _searchNodeNextVarId       :: {-# UNPACK #-} !TVarId+  , _searchNodeMaxTVarId       :: {-# UNPACK #-} !TVarId+  , _searchNodeNextNVarId      :: {-# UNPACK #-} !TVarId -- id used when resolving rankN-types+  , _searchNodeDepth           :: {-# UNPACK #-} !Float+#if LINK_NODES+  , _searchNodePreviousNode    :: Maybe SearchNode+#endif+  , _searchNodeLastStepReason  :: String+  , _searchNodeLastStepBinding :: Maybe String+  }+  deriving Generic++instance NFData VarBinding   where rnf = genericRnf+instance NFData Scope        where rnf = genericRnf+instance NFData Scopes       where rnf = genericRnf+instance NFData SearchNode   where rnf = genericRnf++-- instance Show SearchNode where+--   show (SearchNode sgoals+--               scgoals+--               (Scopes _ scopeMap)+--               _svarUses+--               _sfuncs+--               _sdeconss+--               qClassEnv+--               sexpression+--               snextVarId+--               smaxTVarId+--               snextNVarId+--               sdepth+-- #if LINK_NODES+--               _prev+-- #endif+--               reason+--               _lastStepBinding+--               )+--     = show+--     $ text "SearchNode" <+> (+--           (text   "goals      ="+--            <+> brackets (vcat $ punctuate (text ", ") $ map tgoal $ toList sgoals)+--           )+--       $$  (text $ "constrGoals= " ++ show scgoals)+--       $$  (text   "scopes     = "+--            <+> brackets (vcat $ punctuate (text ", ") $ map tScope $ IntMap.toList scopeMap)+--           )+--       $$  (text $ "classEnv   = " ++ show qClassEnv)+--       $$  (text $ "expression = " ++ showExpression sexpression)+--       $$  (text $ "reason     = " ++ reason)+--       $$  (parens $    (text $ "nextVarId="++show snextVarId)+--                    <+> (text $ "maxTVarId="++show smaxTVarId)+--                    <+> (text $ "nextNVarId="++show snextNVarId)+--                    <+> (text $ "depth="++show sdepth))+--     )+--     where+--       tgoal :: TGoal -> Doc+--       tgoal (vt,scopeId) =  tVarType vt+--                          <> text (" in " ++ show scopeId)+--       tScope :: (ScopeId, Scope) -> Doc+--       tScope (sid, Scope binds supers) =+--             text (show sid ++ " ")+--         <+> parens (text $ show $ supers)+--         <+> text " " <+> brackets (+--                               hcat $ punctuate (text ", ")+--                                                (map tVarPType binds)+--                             )+--       tVarType :: (TVarId, HsType) -> Doc+--       tVarType (i, t) = text $ showVar i ++ " :: " ++ show t+--       tVarPType :: (TVarId, HsType, [HsType], [TVarId], [HsConstraint]) -> Doc+--       tVarPType (i, t, ps, [], []) = tVarType (i, foldr TypeArrow t ps)+--       tVarPType (i, t, ps, fs, cs) = tVarType (i, TypeForall fs cs (foldr TypeArrow t ps))++showSearchNode :: SearchNode -> String+showSearchNode+  (SearchNode sgoals+              scgoals+              (Scopes _ scopeMap)+              _svarUses+              _sfuncs+              _sdeconss+              qClassEnv+              sexpression+              snextVarId+              smaxTVarId+              snextNVarId+              sdepth+#if LINK_NODES+              _prev+#endif+              reason+              _lastStepBinding+              ) =+  let exprStr = showExpression sexpression+  in show+    $ text "SearchNode" <+> (+          (text   "goals      ="+           <+> brackets (vcat $ punctuate (text ", ") $ map tgoal $ toList sgoals)+          )+      $$  (text $ "constrGoals= " ++ show scgoals)+      $$  (text   "scopes     = "+           <+> brackets (vcat $ punctuate (text ", ") $ map tScope $ IntMap.toList scopeMap)+          )+      $$  (text $ "classEnv   = " ++ show qClassEnv)+      $$  (text $ "expression = " ++ exprStr)+      $$  (text $ "reason     = " ++ reason)+      $$  (parens $    (text $ "nextVarId="++show snextVarId)+                   <+> (text $ "maxTVarId="++show smaxTVarId)+                   <+> (text $ "nextNVarId="++show snextNVarId)+                   <+> (text $ "depth="++show sdepth))+    )+ where+  tgoal :: TGoal -> Doc+  tgoal (vt,scopeId) =  tVarType vt+                     <> text (" in " ++ show scopeId)+  tScope :: (ScopeId, Scope) -> Doc+  tScope (sid, Scope binds supers) =+        text (show sid ++ " ")+    <+> parens (text $ show $ supers)+    <+> text " " <+> brackets (+                          hcat $ punctuate (text ", ")+                                           (map tVarPType binds)+                        )+  tVarType :: VarBinding -> Doc+  tVarType (VarBinding i t) = text $ showVar i ++ " :: " ++ show t+  tVarPType :: (TVarId, HsType, [HsType], [TVarId], [HsConstraint]) -> Doc+  tVarPType (i, t, ps, [], []) = tVarType $ VarBinding i (foldr TypeArrow t ps)+  tVarPType (i, t, ps, fs, cs) = tVarType $ VarBinding i (TypeForall fs cs (foldr TypeArrow t ps))++showNodeDevelopment :: SearchNode -> String+#if LINK_NODES+showNodeDevelopment s = case _searchNodePreviousNode s of+  Nothing -> showSearchNode s+  Just p  -> showNodeDevelopment p ++ "\n" ++ showSearchNode s+#else+showNodeDevelopment _ = "[showNodeDevelopment: exference-core was not compiled with -fLinkNodes]"+#endif++-- instance Observable SearchNode where+--   observer state = observeOpaque (show state) state++splitBinding :: VarBinding -> VarPBinding+splitBinding (VarBinding v t) = let (rt,pts,fvs,cs) = splitArrowResultParams t in (v,rt,pts,fvs,cs)++makeFields ''SearchNode

+ src/Language/Haskell/Exference/Core/Internal/ExferenceNodeBuilder.hs view

@@ -0,0 +1,86 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}++module Language.Haskell.Exference.Core.Internal.ExferenceNodeBuilder+  ( SearchNodeBuilder+  , modifyNodeBy+  , builderSetReason+  , builderAppendReason+  , builderGetTVarOffset+  , builderAddScope+  , builderApplySubst+  , builderAllocVar+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.Expression+import Language.Haskell.Exference.Core.Internal.ExferenceNode+import Language.Haskell.Exference.Core.FunctionBinding++import Control.Monad.State ( State+                           , StateT( StateT )+                           , execState+                           , modify+                           , get+                           , put+                           )+import Control.Monad.State.Lazy ( MonadState )+import Control.Applicative+import qualified Data.Map as M+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Vector as V+import Control.Monad ( liftM )++import Control.Lens++++type SearchNodeBuilder a = State SearchNode a++modifyNodeBy :: SearchNode -> SearchNodeBuilder () -> SearchNode+modifyNodeBy = flip execState++{-+builderAddVars :: [TVarId] -> SearchNodeBuilder ()+builderAddVars = (varUses <>=) . M.fromList . map (,0)+-}++-- sets reason, and, as appropriate, lastNode+builderSetReason :: MonadState SearchNode m => String -> m ()+builderSetReason r = do+  lastStepReason .= r+#if LINK_NODES+  previousNode <~ liftM Just get+#endif++builderAppendReason :: MonadState SearchNode m => String -> m ()+builderAppendReason r = do+  lastStepReason %= (++ (", " ++ r))++builderGetTVarOffset :: MonadState SearchNode m => m TVarId+builderGetTVarOffset = liftM (+1) $ use maxTVarId+ -- TODO: is (+1) really necessary? it was in pre-transformation code,+ --       but i cannot find good reason now.. test?++builderAllocVar :: MonadState SearchNode m => m TVarId+builderAllocVar = do+  vid <- use nextVarId+  varUses . at vid ?= 0+  nextVarId <<+= 1++-- take the current scope, add new scope, return new id+builderAddScope :: MonadState SearchNode m => ScopeId -> m ScopeId+builderAddScope parentId = do+  (newId, newScopes) <- uses providedScopes $ addScope parentId+  providedScopes .= newScopes+  return newId++-- apply substs in goals and scopes+-- not contraintGoals, because that's handled by caller+builderApplySubst :: MonadState SearchNode m => Substs -> m ()+builderApplySubst substs = do+  goals . mapped %= goalApplySubst substs+  providedScopes %= scopesApplySubsts substs

+ src/Language/Haskell/Exference/Core/Internal/Unify.hs view

@@ -0,0 +1,249 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MonadComprehensions #-}++module Language.Haskell.Exference.Core.Internal.Unify+  ( unify+  , unifyOffset+  , unifyRight+  , unifyRightEqs+  , unifyRightOffset+  , TypeEq (..)+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IntMap+import Data.Maybe++-- import Debug.Hood.Observe+import Debug.Trace++++data TypeEq = TypeEq !HsType+                     !HsType++data UniState1 = UniState1 [TypeEq] Substs+data UniState2 = UniState2 [TypeEq] Substs Substs++occursIn :: TVarId -> HsType -> Bool+occursIn i (TypeVar j)         = i==j+occursIn _ (TypeConstant _)    = False+occursIn _ (TypeCons _)        = False+occursIn i (TypeArrow t1 t2)   = occursIn i t1 || occursIn i t2+occursIn i (TypeApp t1 t2)     = occursIn i t1 || occursIn i t2+occursIn i (TypeForall js _ t) = (i `notElem` js) && occursIn i t++-- Maybe (Either (Either Subst Subst) [TypeEq])+data StepResult+  = StepFailed+  | StepClear+  | StepNewEqs ![TypeEq]+  | StepLeftSubst {-# UNPACK #-} !Subst+  | StepRightSubst {-# UNPACK #-} !Subst++-- unification of types.+-- returns two substitutions: one for variables in the first type,+-- one for variables in the second. In the symmetric case,+-- substituting the right-hand (second) type will be preferred.+-- examples:+-- unify v C -> ([v=>C], [])+-- unify C v -> ([], [v=>C])+-- unify v w -> ([], [w=>v])+{-# INLINE unify #-}+unify :: HsType -> HsType -> Maybe (Substs, Substs)+unify ut1 ut2 = unify' $ UniState2 [TypeEq ut1 ut2] IntMap.empty IntMap.empty+  where+    unify' :: UniState2 -> Maybe (Substs, Substs)+    unify' (UniState2 [] l r)      = Just (l, r)+    unify' (UniState2 (x:xr) l r) = case uniStep x of+      StepFailed                       -> Nothing+      StepClear                        -> unify' $ UniState2 xr l r+      StepNewEqs eqs                   -> unify' $ UniState2 (eqs++xr) l r+      StepLeftSubst  subst@(Subst i t) ->+        unify' $ let f = applySubst subst in UniState2+          [ TypeEq (f a) b | TypeEq a b <- xr ]+          (IntMap.insert i t $ IntMap.map f l)+          r+      StepRightSubst subst@(Subst i t) ->+        unify' $ let f = applySubst subst in UniState2+          [ TypeEq a (f b) | TypeEq a b <- xr ]+          l+          (IntMap.insert i t $ IntMap.map f r)+      {-+      \ms -> unify' $ case ms of+        Left (Left subst@(Subst i t)) -> let f = applySubst subst in UniState2+          [ TypeEq (f a) b | TypeEq a b <- xr ]+          (IntMap.insert i t $ IntMap.map f l)+          r+        Left (Right subst@(Subst i t)) -> let f = applySubst subst in UniState2+          [ TypeEq a (f b) | TypeEq a b <- xr ]+          l+          (IntMap.insert i t $ IntMap.map f r)+        Right eqs -> UniState2 (eqs++xr) l r+      ) -- up here is the same control flow again, with the deconsing and the growing of the tail... maybe make your own hof for now? oh wait you also modify the tail+      -}+    uniStep :: TypeEq -> StepResult+    -- uniStep (TypeEq (TypeVar i1) (TypeVar i2)) | i1==i2 = Just (Right [])+    uniStep (TypeEq t1 (TypeVar i2)) = if occursIn i2 t1+      then StepFailed+      else StepRightSubst $ Subst i2 t1+    uniStep (TypeEq (TypeVar i1) t2) = if occursIn i1 t2+      then StepFailed+      else StepLeftSubst $ Subst i1 t2+    uniStep (TypeEq (TypeConstant i1) (TypeConstant i2)) | i1 == i2 = StepClear+    uniStep (TypeEq (TypeCons s1) (TypeCons s2)) | s1 == s2 = StepClear+    uniStep (TypeEq (TypeArrow t1 t2) (TypeArrow t3 t4)) = StepNewEqs [TypeEq t1 t3, TypeEq t2 t4]+    uniStep (TypeEq (TypeApp t1 t2) (TypeApp t3 t4)) = StepNewEqs [TypeEq t1 t3, TypeEq t2 t4]+    -- TODO TypeForall unification+    -- THIS IS WRONG; WE IGNORE FORALLS FOR THE MOMENT+    -- uniStep (TypeEq (TypeForall _ _ t1) (t2)) = uniStep $ TypeEq t1 t2+    -- uniStep (TypeEq (t1) (TypeForall _ _ t2)) = uniStep $ TypeEq t1 t2+    uniStep (TypeEq TypeForall{} _) = error "this probably does not ever happen anymore, as foralls are treated previously."+    uniStep (TypeEq _ TypeForall{}) = error "this probably does not ever happen anymore, as foralls are treated previously."+    uniStep _ = StepFailed+++{-# INLINE unifyOffset #-}                   -- left, rightOffset+unifyOffset :: HsType -> HsTypeOffset -> Maybe (Substs, Substs)+unifyOffset ut1 (HsTypeOffset ut2 offset) = unify' $ UniState2 [TypeEq ut1 ut2]+                                                               IntMap.empty+                                                               IntMap.empty+  where+    unify' :: UniState2 -> Maybe (Substs, Substs)+    unify' (UniState2 [] l r)      = Just (l, r)+    unify' (UniState2 (x:xr) l r) = uniStep x >>= (+      \ms -> unify' $ case ms of+        Left (Left subst@(Subst i t)) -> let f = applySubst subst in UniState2+          [ TypeEq (f a) b | TypeEq a b <- xr ]+          (IntMap.insert i t $ IntMap.map f l)+          r+        Left (Right (substInternal, Subst substExtI substExtT)) ->+          let f = applySubst substInternal+          in UniState2+            [ TypeEq a (f b) | TypeEq a b <- xr ]+            l+            (IntMap.insert substExtI substExtT $ IntMap.map f r)+        Right eqs -> UniState2 (eqs++xr) l r+      )+    uniStep :: TypeEq -> Maybe (Either (Either Subst (Subst, Subst)) [TypeEq])+    uniStep (TypeEq (TypeVar i1) (TypeVar i2)) | i1==offset+i2 = Just (Right [])+    uniStep (TypeEq (t1) (TypeVar i2)) = if occursIn (offset+i2) t1+      then Nothing+      else Just $ Left $ Right (Subst i2 t1, Subst (i2+offset) t1)+    uniStep (TypeEq (TypeVar i1) (t2)) = if occursIn (i1-offset) t2+      then Nothing+      else Just $ Left $ Left $ Subst i1 (incVarIds (+offset) t2)+    uniStep (TypeEq (TypeConstant i1) (TypeConstant i2)) | i1==i2 = Just (Right [])+    uniStep (TypeEq (TypeCons s1) (TypeCons s2)) | s1==s2 = Just (Right [])+    uniStep (TypeEq (TypeArrow t1 t2) (TypeArrow t3 t4)) = Just (Right [TypeEq t1 t3, TypeEq t2 t4])+    uniStep (TypeEq (TypeApp t1 t2) (TypeApp t3 t4)) = Just (Right [TypeEq t1 t3, TypeEq t2 t4])+    -- TODO TypeForall unification+    -- THIS IS WRONG; WE IGNORE FORALLS FOR THE MOMENT+    uniStep (TypeEq (TypeForall _ _ t1) (t2)) = uniStep $ TypeEq t1 t2+    uniStep (TypeEq (t1) (TypeForall _ _ t2)) = uniStep $ TypeEq t1 t2+    uniStep _ = Nothing++-- treats the variables in the first parameter as constants, and returns+-- the variable bindings for the second parameter that unify both types.+{-# INLINE unifyRight #-}+unifyRight :: HsType -> HsType -> Maybe Substs+unifyRight ut1 ut2 = unifyRightEqs [TypeEq ut1 ut2]++{-# INLINE unifyRightEqs #-}+unifyRightEqs :: [TypeEq] -> Maybe Substs+unifyRightEqs teqs = unify' $ UniState1 teqs IntMap.empty+  where+    unify' :: UniState1 -> Maybe Substs+    unify' (UniState1 [] x) = Just x+    unify' (UniState1 (x:xr) ss) = uniStepRight x >>= (+      \r -> unify' $ case r of+        Left subst@(Subst i t) -> let f = applySubst subst in UniState1+          [ TypeEq a (f b) | TypeEq a b <- xr]+          (IntMap.insert i t $ IntMap.map f ss)+        Right eqs -> UniState1 (eqs++xr) ss+      )+++-- treats the variables in the first parameter as constants, and returns+-- the variable bindings for the second parameter that unify both types.+{-# INLINE unifyRightOffset #-}+unifyRightOffset :: HsType -> HsTypeOffset -> Maybe Substs+unifyRightOffset ut1 (HsTypeOffset ut2 offset) = unify' $ UniState1 [TypeEq ut1 ut2] IntMap.empty+  where+    unify' :: UniState1 -> Maybe Substs+    unify' (UniState1 [] x) = Just x+    unify' (UniState1 (x:xr) ss) = uniStep x >>= (+      \r -> unify' $ case r of+        Left (substInternal, Subst substExtI substExtT) -> UniState1+          [ TypeEq a (applySubst substInternal b) | TypeEq a b <- xr]+          (IntMap.insert substExtI substExtT ss)+        Right eqs -> UniState1 (eqs++xr) ss+      )+    uniStep :: TypeEq -> Maybe (Either (Subst, Subst) [TypeEq])+    uniStep (TypeEq (TypeVar i1) (TypeVar i2)) | i1==offset+i2 = Just (Right [])+    uniStep (TypeEq (t1) (TypeVar i2)) = if occursIn (i2+offset) t1+      then Nothing+      else Just $ Left (Subst i2 t1, Subst (i2+offset) t1)+    uniStep (TypeEq (TypeVar _) _) = Nothing+    uniStep (TypeEq (TypeConstant i1) (TypeConstant i2)) | i1==i2 = Just (Right [])+    uniStep (TypeEq (TypeCons s1) (TypeCons s2)) | s1==s2 = Just (Right [])+    uniStep (TypeEq (TypeArrow t1 t2) (TypeArrow t3 t4)) = Just (Right [TypeEq t1 t3, TypeEq t2 t4])+    uniStep (TypeEq (TypeApp t1 t2) (TypeApp t3 t4)) = Just (Right [TypeEq t1 t3, TypeEq t2 t4])+    -- TODO TypeForall unification+    -- THIS IS WRONG; WE IGNORE FORALLS FOR THE MOMENT+    uniStep (TypeEq (TypeForall _ _ t1) t2)   = uniStep $ TypeEq t1 t2+    uniStep (TypeEq (t1) (TypeForall _ _ t2)) = uniStep $ TypeEq t1 t2+    uniStep _ = Nothing+++uniStepRight :: TypeEq -> Maybe (Either Subst [TypeEq])+uniStepRight (TypeEq (TypeVar i1) (TypeVar i2)) | i1==i2 = Just (Right [])+uniStepRight (TypeEq (t1) (TypeVar i2)) = if occursIn i2 t1+  then Nothing+  else Just $ Left $ Subst i2 t1+uniStepRight (TypeEq (TypeVar _) _) = Nothing+uniStepRight (TypeEq (TypeConstant i1) (TypeConstant i2)) | i1==i2 = Just (Right [])+uniStepRight (TypeEq (TypeCons s1) (TypeCons s2)) | s1==s2 = Just (Right [])+uniStepRight (TypeEq (TypeArrow t1 t2) (TypeArrow t3 t4)) = Just (Right [TypeEq t1 t3, TypeEq t2 t4])+uniStepRight (TypeEq (TypeApp t1 t2) (TypeApp t3 t4)) = Just (Right [TypeEq t1 t3, TypeEq t2 t4])+-- TODO TypeForall unification+-- THIS IS WRONG; WE IGNORE FORALLS FOR THE MOMENT+uniStepRight (TypeEq (TypeForall _ _ t1) t2)   = uniStepRight $ TypeEq t1 t2+uniStepRight (TypeEq (t1) (TypeForall _ _ t2)) = uniStepRight $ TypeEq t1 t2+uniStepRight _ = Nothing++++--unifyDist :: HsType -> HsType -> Maybe Substs+--unifyDist t1 t2 = unify t1 $ distinctify t1 t2++-- tries to unify two types, under the assumption that one is supposed+-- to serve as the parameter (at some levels) to the other one (when at+-- least one is a function, that is.)+-- either is BROKEN, or does something other than i expected.+-- not used (or needed) anyway, so.. deletion candidate.+{-+inflateUnify :: HsType -> HsType -> [HsType]+inflateUnify t1 t2 =+  let d1 = arrowDepth t1+      d2 = arrowDepth t2+  in if d1 > d2+    then f t1 $ inflateTo d1 t2+    else f t2 $ inflateTo d2 t1+  where+    inflateTo :: Int -> HsType -> [HsType]+    inflateTo n t = map (createArrow t (map TypeVar [1000..998+n])) [0..n-1]+    createArrow t varIds i =+      let (l,r) = splitAt i varIds+          types = l++[t]++r+      in foldr1 TypeArrow types+    f :: HsType -> [HsType] -> [HsType]+    f ft1 ft2s = catMaybes [g ft1 (distinctify ft1 ft2) | ft2 <- ft2s]+    g :: HsType -> HsType -> Maybe HsType+    g gt1 gt2 = fmap (\subst -> reduceIds $ applySubsts subst gt1) (unify gt1 gt2)+-}

+ src/Language/Haskell/Exference/Core/SearchTree.hs view

@@ -0,0 +1,86 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}++module Language.Haskell.Exference.Core.SearchTree+  ( SearchTree+  , SearchTreeValue+  , SearchTreeBuilder+  , initialSearchTreeBuilder+  , buildSearchTree+  , filterSearchTreeN+  , filterSearchTreeProcessedN+  , takeSearchTree+  )  +where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.Expression++import Data.Tree+import Data.Maybe ( fromMaybe )+import Control.Monad.Reader+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Hashable ( Hashable )+import Control.Lens hiding ( children )++++type SearchTreeValue = ( Int         -- total number of children+                       , Int         -- number of processed children+                       , Expression  -- expression+                       )++type SearchTree = Tree SearchTreeValue+++type SearchTreeBuilder a = ( [(a, a, Expression)] -- id, parentid, expr,+                           , [a]                  -- processed list+                           )++buildSearchTree :: forall a+                 . (Eq a, Hashable a)+                => SearchTreeBuilder a+                -> a+                -> SearchTree+buildSearchTree (assocs,processed) root = ff $ unfoldTree (\x -> (x, children x)) root where+  ff (Node x xs)+    | subtrees <- map ff xs+    = Node (                         1        + sumOf (folded . to rootLabel . _1) subtrees+           , if elemProcessed x then 1 else 0 + sumOf (folded . to rootLabel . _2) subtrees+           , values x)+           subtrees+  elemProcessed = flip HS.member $ HS.fromList processed+  values = (HM.!) $ HM.fromList $ map (\(i,_,v) -> (i,v)) assocs+  children = fromMaybe [] . flip HM.lookup+    (HM.fromListWith (++) $ assocs >>= \(i,p,_) -> if i==p then [] else [(p, [i])])++initialSearchTreeBuilder :: a -> Expression -> SearchTreeBuilder a+initialSearchTreeBuilder x e = ([(x,x,e)],[])++-- removes all nodes that have less than n total nodes (incl. self)+-- e.g. if n==2, all nodes without children are removed.+filterSearchTreeN :: Int -> SearchTree -> SearchTree+filterSearchTreeN n (Node d ts) = Node d (ts >>= f)+  where+    f :: SearchTree -> [SearchTree]+    f (Node d'@(k,_,_) ts') | n>k = []+                            | otherwise = [Node d' $ ts' >>= f]++-- removes all nodes that have less than n total nodes (incl. self)+-- e.g. if n==2, all nodes without children are removed.+filterSearchTreeProcessedN :: Int -> SearchTree -> SearchTree+filterSearchTreeProcessedN n (Node d ts) = Node d (ts >>= f)+  where+    f :: SearchTree -> [SearchTree]+    f (Node d'@(_,k,_) ts') | n>k = []+                            | otherwise = [Node d' $ ts' >>= f]++-- limits depth of tree+takeSearchTree :: Int -> SearchTree -> SearchTree+takeSearchTree 0 (Node d _) = Node d []+takeSearchTree n _ | n<0 = error "takeSearchTree: negative depth"+takeSearchTree n (Node d ts) = Node d [takeSearchTree (n-1) t | t <- ts]

+ src/Language/Haskell/Exference/Core/TypeUtils.hs view

@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Exference.Core.TypeUtils+  ( incVarIds+  , largestId+  , largestSubstsId+  , forallify -- unused atm+  , mkStaticClassEnv+  , constraintMapTypes+  , constraintContainsVariables+  , unknownTypeClass+  , inflateInstances+  , splitArrowResultParams+  )+where++++import qualified Data.Set as S+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IntMap+import Data.Char ( ord, chr, isLower, isUpper )+import Control.Applicative ( (<$>), (<*>), (*>), (<*) )+import Data.Maybe ( maybeToList, fromMaybe )+import Text.Printf ( printf )++import Control.Monad.State.Strict+import Control.DeepSeq.Generics+import GHC.Generics++import Language.Haskell.Exference.Core.Types+-- import Language.Haskell.Exference.Core.Internal.Unify+import Data.List ( intercalate, find )+import Control.Monad ( mplus, guard )+import Control.Monad.Identity ( Identity(runIdentity) )++import Control.Monad.Trans.MultiState ( MonadMultiState(..) )+import Control.Monad.Trans.MultiRWS++import Control.Lens ( ala )++-- import Debug.Hood.Observe+import Debug.Trace++++-- binds everything in Foralls, so there are no free variables anymore.+forallify :: HsType -> HsType+forallify t = case t of+  TypeForall is cs t' -> TypeForall (S.toList frees++is) cs t'+  _                   -> TypeForall (S.toList frees) [] t+ where frees = freeVars t++incVarIds :: (TVarId -> TVarId) -> HsType -> HsType+incVarIds f (TypeVar i) = TypeVar (f i)+incVarIds f (TypeArrow t1 t2) = TypeArrow (incVarIds f t1) (incVarIds f t2)+incVarIds f (TypeApp t1 t2) = TypeApp (incVarIds f t1) (incVarIds f t2)+incVarIds f (TypeForall is cs t) = TypeForall+                                     (f <$> is)+                                     (g <$> cs) +                                     (incVarIds f t)+  where+    g (HsConstraint cls params) = HsConstraint cls (incVarIds f <$> params)+incVarIds _ t = t++largestId :: HsType -> TVarId+largestId (TypeVar i)       = i+largestId (TypeConstant _)  = -1+largestId (TypeCons _)      = -1+largestId (TypeArrow t1 t2) = largestId t1 `max` largestId t2+largestId (TypeApp t1 t2)   = largestId t1 `max` largestId t2+largestId (TypeForall _ _ t)  = largestId t++largestSubstsId :: Substs -> TVarId+largestSubstsId = IntMap.foldl' (\a b -> a `max` largestId b) 0++constraintMapTypes :: (HsType -> HsType) -> HsConstraint -> HsConstraint+constraintMapTypes f (HsConstraint a ts) = HsConstraint a (map f ts)+++mkStaticClassEnv :: [HsTypeClass] -> [HsInstance] -> StaticClassEnv+mkStaticClassEnv tclasses insts = StaticClassEnv tclasses (helper insts)+  where+    helper :: [HsInstance] -> M.Map QualifiedName [HsInstance]+    helper is = M.fromListWith (++)+              $ [ (tclass_name $ instance_tclass i, [i]) | i <- is ]++constraintContainsVariables :: HsConstraint -> Bool+constraintContainsVariables = any ((-1/=).largestId) . constraint_params++-- TODO: it probably is a bad idea to have any unknown type class mapped to+--       this, as they might unify at some point.. even if they distinct.+unknownTypeClass :: HsTypeClass+unknownTypeClass = HsTypeClass qid [] []+  where+    qid = QualifiedName [] "EXFUnknownTC"+  ++inflateInstances :: [HsInstance] -> [HsInstance]+inflateInstances = ala S.fromList id . concat . takeWhile (not . null) . iterate (concatMap f)+  where+    f :: HsInstance -> [HsInstance]+    f (HsInstance iconstrs tclass iparams)+      | (HsTypeClass _ tparams tconstrs) <- tclass+      , substs <- IntMap.fromList $ zip tparams iparams+      = let +          g :: HsConstraint -> HsInstance+          g (HsConstraint ctclass cparams) =+            HsInstance iconstrs ctclass $ map (snd . applySubsts substs) cparams+        in map g tconstrs++splitArrowResultParams :: HsType -> (HsType, [HsType], [TVarId], [HsConstraint])+splitArrowResultParams t+  | TypeArrow t1 t2 <- t+  , (rt,pts,fvs,cs) <- splitArrowResultParams t2+  = (rt, t1:pts, fvs, cs)+  | TypeForall vs cs t1 <- t+  , (rt, pts, fvs, cs') <- splitArrowResultParams t1+  = (rt, pts, vs++fvs, cs++cs')+  | otherwise+  = (t, [], [], [])

+ src/Language/Haskell/Exference/Core/Types.hs view

@@ -0,0 +1,399 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Language.Haskell.Exference.Core.Types+  ( TVarId+  , QualifiedName(..)+  , HsType (..)+  , HsTypeOffset (..)+  , Subst (..)+  , Substs+  , HsTypeClass (..)+  , HsInstance (..)+  , HsConstraint (..)+  , StaticClassEnv (..)+  , QueryClassEnv ( qClassEnv_env+                  , qClassEnv_constraints+                  , qClassEnv_inflatedConstraints+                  , qClassEnv_varConstraints )+  , constraintApplySubsts+  , inflateHsConstraints+  , applySubst+  , applySubsts+  -- , typeParser+  , containsVar+  , showVar+  , showTypedVar+  , mkQueryClassEnv+  , addQueryClassEnv+  , freeVars+  , showHsConstraint+  , TypeVarIndex+  , showHsType+#if !MIN_VERSION_base(4,8,0)+  , Alt (..)+#endif+  )+where++++import Data.Char ( ord, chr, isLower, isUpper, toLower )+import Data.List ( intercalate, intersperse )+import Data.Foldable ( fold, foldMap )+import Control.Applicative ( (<$>), (<*>), (*>), (<*) )+import Data.Maybe ( maybeToList, fromMaybe )+import Data.Monoid ( Monoid(..), Any(..) )+import Control.Monad ( liftM, liftM2, MonadPlus )+import Control.Applicative ( Applicative, Alternative, empty, (<|>) )+import Control.Arrow ( first )+import Data.Orphans ()++import qualified Data.Set as S+import qualified Data.IntSet as IntSet+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IntMap+import qualified Data.List as L++import Text.ParserCombinators.Parsec hiding (State, (<|>))+import Text.ParserCombinators.Parsec.Char++import Language.Haskell.Exts.Syntax ( Name (..) )++import Control.DeepSeq.Generics+import Control.DeepSeq+import GHC.Generics+import Data.Data ( Data )+import Data.Typeable ( Typeable )+import Control.Monad.Trans.MultiState+import Safe++import Debug.Hood.Observe+import Debug.Trace++++#if !MIN_VERSION_base(4,8,0)+newtype Alt f a = Alt {getAlt :: f a}+  deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum,+            Monad, MonadPlus, Applicative, Alternative, Functor)++instance forall f a . Alternative f => Monoid (Alt f a) where+        mempty = Alt empty+        (Alt x) `mappend` (Alt y) = Alt (x <|> y)+#endif++type TVarId = Int+data Subst  = Subst {-# UNPACK #-} !TVarId !HsType+type Substs = IntMap.IntMap HsType++data QualifiedName+  = QualifiedName [String] String+  | ListCon+  | TupleCon Int+  | Cons+  deriving (Eq, Ord, Generic, Data, Typeable)++data HsType = TypeVar      {-# UNPACK #-} !TVarId+            | TypeConstant {-# UNPACK #-} !TVarId+              -- like TypeCons, for exference-internal purposes.+            | TypeCons     QualifiedName+            | TypeArrow    !HsType !HsType+            | TypeApp      !HsType !HsType+            | TypeForall   [TVarId] [HsConstraint] !HsType+  deriving (Ord, Eq, Generic, Data, Typeable)++data HsTypeOffset = HsTypeOffset !HsType {-# UNPACK #-} !Int++type TypeVarIndex = M.Map Name Int++data HsTypeClass = HsTypeClass+  { tclass_name :: QualifiedName+  , tclass_params :: [TVarId]+  , tclass_constraints :: [HsConstraint]+  }+  deriving (Eq, Show, Ord, Generic, Data, Typeable)++data HsInstance = HsInstance+  { instance_constraints :: [HsConstraint]+  , instance_tclass :: HsTypeClass+  , instance_params :: [HsType]+  }+  deriving (Eq, Show, Ord, Generic, Data, Typeable)++data HsConstraint = HsConstraint+  { constraint_tclass :: HsTypeClass+  , constraint_params :: [HsType]+  }+  deriving (Eq, Ord, Generic, Data, Typeable)++data StaticClassEnv = StaticClassEnv+  { sClassEnv_tclasses :: [HsTypeClass]+  , sClassEnv_instances :: M.Map QualifiedName [HsInstance]+  }+  deriving (Show, Generic, Data, Typeable)++data QueryClassEnv = QueryClassEnv+  { qClassEnv_env :: StaticClassEnv+  , qClassEnv_constraints :: S.Set HsConstraint+  , qClassEnv_inflatedConstraints :: S.Set HsConstraint+  , qClassEnv_varConstraints :: IntMap.IntMap (S.Set HsConstraint)+  }+  deriving (Generic)++instance NFData QualifiedName  where rnf = genericRnf+instance NFData HsType         where rnf = genericRnf+instance NFData HsTypeClass    where rnf = genericRnf+instance NFData HsInstance     where rnf = genericRnf+instance NFData HsConstraint   where rnf = genericRnf+instance NFData StaticClassEnv where rnf = genericRnf+instance NFData QueryClassEnv  where rnf = genericRnf++instance Show QualifiedName where+  show (QualifiedName ns n) = if    length n >= 2+                                 && head n == '('+                                 && last n == ')'+                              then "(" ++ intercalate "." (ns ++ [tail n])+                              else        intercalate "." (ns ++ [n])+  show ListCon              = "[]"+  show (TupleCon 0)         = "()"+  show (TupleCon i)         = "(" ++ replicate (i-1) ',' ++ ")"+  show Cons                 = "(:)"++instance Show HsType where+  showsPrec _ (TypeVar i) = showString $ showVar i+  showsPrec _ (TypeConstant i) = showString $ "C" ++ showVar i+  showsPrec d (TypeCons s) = showsPrec d s+  showsPrec d (TypeArrow t1 t2) =+    showParen (d> -2) $ showsPrec (-1) t1 . showString " -> " . showsPrec (-1) t2+  showsPrec d (TypeApp t1 t2) =+    showParen (d> -1) $ showsPrec 0 t1 . showString " " . showsPrec 0 t2+  showsPrec d (TypeForall [] [] t) = showsPrec d t+  showsPrec d (TypeForall is cs t) =+    showParen (d>0)+    $ showString ("forall " ++ intercalate ", " (showVar <$> is) ++ " . ")+    . showParen True (\x -> foldr (++) x $ intersperse ", " $ map show cs)+    . showString " => "+    . showsPrec (-2) t++showHsType :: TypeVarIndex -> HsType -> String+showHsType convMap t = h 0 t ""+ where+  h :: Int -> HsType -> ShowS+  h _ (TypeVar i)      = showString+                       $ maybe "badNameInternalError"+                               (\(Ident n, _) -> n)+                       $ L.find ((i ==) .  snd)+                       $ M.toList convMap+  h _ (TypeConstant i) = showString+                       $ maybe "badNameInternalError"+                               (\(Ident n, _) -> n)+                       $ L.find ((i ==) .  snd)+                       $ M.toList convMap+  h _ (TypeCons s) = shows s+  h d (TypeArrow t1 t2) =+    showParen (d> -2) $ t1Shows . showString " -> " . t2Shows+    where+      t1Shows = h (-1) t1+      t2Shows = h (-1) t2+  h d (TypeApp t1 t2) =+    showParen (d> -1) $ t1Shows . showString " " . t2Shows+    where+      t1Shows = h 0 t1+      t2Shows = h 0 t2+  h d (TypeForall [] [] ty) = h d ty+  h d (TypeForall is cs ty) =+    showParen (d>0)+      $ showString ("forall " ++ intercalate ", " (showVar <$> is) ++ " . ")+      . showParen True (\x -> foldr (++) x $ intersperse ", " $ map show cs)+      . showString " => "+      . tShows+    where+      tShows = h (-2) ty++instance Observable HsType where+  observer x = observeOpaque (show x) x++-- instance Read HsType where+--   readsPrec _ = maybeToList . parseType++instance Show HsConstraint where+  show (HsConstraint c ps) = unwords $ show (tclass_name c) : map show ps++showHsConstraint :: TypeVarIndex+                 -> HsConstraint+                 -> String+showHsConstraint convMap (HsConstraint c ps) =+  unwords $ show name : tyStrs  + where+  name = tclass_name c+  tyStrs = showHsType convMap <$> ps+  ++instance Show QueryClassEnv where+  show (QueryClassEnv _ cs _ _) = "(QueryClassEnv _ " ++ show cs ++ " _)"+instance Observable HsConstraint where+  observer x = observeOpaque (show x) x++instance Observable QueryClassEnv where+  observer x = observeOpaque (show x) x++instance Observable HsInstance where+  observer x = observeOpaque (show x) x++filterHsConstraintsByVarId :: TVarId+                           -> S.Set HsConstraint+                           -> S.Set HsConstraint+filterHsConstraintsByVarId i = S.filter+                             $ any (containsVar i) . constraint_params++containsVar :: TVarId -> HsType -> Bool+containsVar i = S.member i . freeVars++mkQueryClassEnv :: StaticClassEnv -> [HsConstraint] -> QueryClassEnv+mkQueryClassEnv sClassEnv constrs = addQueryClassEnv constrs $ QueryClassEnv {+  qClassEnv_env = sClassEnv,+  qClassEnv_constraints = S.empty,+  qClassEnv_inflatedConstraints = S.empty,+  qClassEnv_varConstraints = IntMap.empty+}++addQueryClassEnv :: [HsConstraint] -> QueryClassEnv -> QueryClassEnv+addQueryClassEnv constrs env = env {+  qClassEnv_constraints = csSet,+  qClassEnv_inflatedConstraints = inflateHsConstraints csSet,+  qClassEnv_varConstraints = helper constrs+}+  where+    csSet = S.fromList constrs `S.union` qClassEnv_constraints env+    helper :: [HsConstraint] -> IntMap.IntMap (S.Set HsConstraint)+    helper cs =+      let ids :: IntSet.IntSet+          ids = IntSet.fromList $ S.toList $ fold $ freeVars <$> (constraint_params =<< cs)+      in IntMap.fromSet (flip filterHsConstraintsByVarId+                        $ inflateHsConstraints csSet) ids++inflateHsConstraints :: S.Set HsConstraint -> S.Set HsConstraint+inflateHsConstraints = inflate (S.fromList . f)+  where+    f :: HsConstraint -> [HsConstraint]+    f (HsConstraint (HsTypeClass _ ids constrs) ps) =+      map (snd . constraintApplySubsts (IntMap.fromList $ zip ids ps)) constrs++-- uses f to find new elements. adds these new elements, and recursively+-- tried to find even more elements. will not terminate if there are cycles+-- in the application of f+inflate :: (Ord a, Show a) => (a -> S.Set a) -> S.Set a -> S.Set a+inflate f = fold . takeWhile (not . S.null) . iterate (foldMap f)++constraintApplySubst :: Subst -> HsConstraint -> HsConstraint+constraintApplySubst s (HsConstraint c ps) =+  HsConstraint c $ map (applySubst s) ps++-- returns if any change was necessary,+-- plus the (potentially changed) constraint+-- constraintApplySubst' :: Subst -> HsConstraint -> (Bool, HsConstraint)+-- constraintApplySubst' s (HsConstraint c ps) =+--   let applied = map (applySubst' s) ps+--   in (any fst applied, HsConstraint c $ snd <$> applied)++-- returns if any change was necessary,+-- plus the (potentially changed) constraint+{-# INLINE constraintApplySubsts #-}+constraintApplySubsts :: Substs -> HsConstraint -> (Any, HsConstraint)+constraintApplySubsts ss c+  | IntMap.null ss = return c+  | HsConstraint cl ps <- c =+    HsConstraint cl <$> mapM (applySubsts ss) ps++showVar :: TVarId -> String+showVar 0 = "v0"+showVar i | i<27      = [chr (ord 'a' + i - 1)]+          | otherwise = "t"++show (i-27)++showTypedVar :: forall m+              . ( MonadMultiState (M.Map TVarId HsType) m )+             => TVarId+             -> m String+showTypedVar i = do+  m <- mGet+  fromJustNote "missing collectVarTypes before showTypedVar"+    $ h <$> M.lookup i m+ where+  -- h t | traceShow (i, t) False = undefined+  h TypeVar{}          = return $ showVar i+  h TypeConstant{}     = return $ showVar i+  h (TypeCons qName) = do+    return $ case qName of+      QualifiedName _ (c:_) -> toLower c : show i+      QualifiedName{}       -> showVar i+      ListCon               -> showVar i ++ "s"+      TupleCon{}            -> showVar i+      Cons                  -> showVar i+  h TypeArrow{}        = return $ "f" ++ show i+  h (TypeApp t _)      = h t+  h (TypeForall _ _ t) = h t++-- parseType :: _ => String -> m (Maybe (HsType, String))+-- parseType s = either (const Nothing) Just+--             $ runParser (    (,)+--                          <$> typeParser+--                          <*> many anyChar)+--                         ()+--                         ""+--                         s+-- +-- typeParser :: forall m . (_) => Parser (m HsType)+-- typeParser = parseAll+--   where+--     parseAll :: Parser (m HsType)+--     parseAll = parseUn >>= parseBin+--     parseUn :: Parser (m HsType) -- TODO: forall+--     parseUn = spaces *> (+--             try (TypeCons . QualifiedName [] <$> ((:) <$> satisfy isUpper <*> many alphaNum))+--         <|> try ((TypeVar . (\x -> x - ord 'a') . ord) <$> satisfy isLower)+--         <|>     (char '(' *> parseAll <* char ')')+--       )+--     parseBin :: HsType -> Parser HsType+--     parseBin left =+--         try (    try (TypeArrow left <$> (spaces *> string "->" *> parseAll))+--              <|>     ((TypeApp   left <$> (space *> parseUn)) >>= parseBin)+--              )+--         <|>+--         (spaces *> return left)++applySubst :: Subst -> HsType -> HsType+applySubst (Subst i t) v@(TypeVar j) = if i==j then t else v+applySubst _ c@(TypeConstant _) = c+applySubst _ c@(TypeCons _)     = c+applySubst s (TypeArrow t1 t2)  = TypeArrow (applySubst s t1) (applySubst s t2)+applySubst s (TypeApp t1 t2)    = TypeApp (applySubst s t1) (applySubst s t2)+applySubst s@(Subst i _) f@(TypeForall js cs t) = if i `elem` js+  then f+  else TypeForall js (constraintApplySubst s <$> cs) (applySubst s t)++applySubsts :: Substs -> HsType -> (Any, HsType)+applySubsts s v@(TypeVar i)      = fromMaybe (return v)+                                  $ (,) (Any True) <$> IntMap.lookup i s+applySubsts _ c@(TypeConstant _) = return c+applySubsts _ c@(TypeCons _)     = return c+applySubsts s (TypeArrow t1 t2)  = liftM2 TypeArrow (applySubsts s t1) (applySubsts s t2)+applySubsts s (TypeApp t1 t2)    = liftM2 TypeApp   (applySubsts s t1) (applySubsts s t2)+applySubsts s (TypeForall js cs t) = liftM2 (TypeForall js) +  (sequence $ constraintApplySubsts s <$> cs)+  (applySubsts (foldr IntMap.delete s js) t)++freeVars :: HsType -> S.Set TVarId+freeVars (TypeVar i)         = S.singleton i+freeVars (TypeConstant _)    = S.empty+freeVars (TypeCons _)        = S.empty+freeVars (TypeArrow t1 t2)   = S.union (freeVars t1) (freeVars t2)+freeVars (TypeApp t1 t2)     = S.union (freeVars t1) (freeVars t2)+freeVars (TypeForall is _ t) = foldr S.delete (freeVars t) is++-- instance Monoid w => Monad ((,) w) where+--   return = (,) mempty+--   (w,x) >>= f = first (mappend w) (f x)

+ src/Language/Haskell/Exference/EnvironmentParser.hs view

@@ -0,0 +1,327 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonadComprehensions #-}++module Language.Haskell.Exference.EnvironmentParser+  ( parseModules+  , parseModulesSimple+  , environmentFromModuleAndRatings+  , environmentFromPath+  , haskellSrcExtsParseMode+  , compileWithDict+  )+where++++import Language.Haskell.Exference+import Language.Haskell.Exference.ExpressionToHaskellSrc+import Language.Haskell.Exference.BindingsFromHaskellSrc+import Language.Haskell.Exference.ClassEnvFromHaskellSrc+import Language.Haskell.Exference.TypeDeclsFromHaskellSrc+import Language.Haskell.Exference.TypeFromHaskellSrc+import Language.Haskell.Exference.Core.FunctionBinding+import Language.Haskell.Exference.FunctionDecl++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.SimpleDict+import Language.Haskell.Exference.Core.Expression+import Language.Haskell.Exference.Core.ExferenceStats++import Control.DeepSeq++import System.Process++import Control.Applicative ( (<$>), (<*>), (<*) )+import Control.Arrow ( (***) )+import Control.Monad ( when, forM_, guard, forM, mplus, mzero )+import Data.List ( sortBy, find, isSuffixOf )+import Data.Ord ( comparing )+import Text.Printf+import Data.Maybe ( listToMaybe, fromMaybe, maybeToList, catMaybes )+import Data.Either ( lefts, rights )+import Control.Monad.Writer.Strict+import System.Directory ( getDirectoryContents )+import Control.Exception ( try, SomeException )+import Data.Bifunctor ( first, second )++import Language.Haskell.Exts.Syntax ( Module(..), Decl(..), ModuleName(..) )+import Language.Haskell.Exts.Parser ( parseModuleWithMode+                                    , parseModule+                                    , ParseResult (..)+                                    , ParseMode (..)+                                    , defaultParseMode )+import Language.Haskell.Exts.Extension ( Language (..)+                                       , Extension (..)+                                       , KnownExtension (..) )++import Data.List.Split ( chunksOf )+import Control.Monad.Trans.MultiRWS+import Data.HList.ContainsType++import Language.Haskell.Exference.Core.TypeUtils++import qualified Data.Map as M+import qualified Data.IntMap as IntMap+++builtInDeclsM :: (Monad m) => MultiRWST r w s m [HsFunctionDecl]+builtInDeclsM = do+  let consType = (Cons, TypeArrow+            (TypeVar 0)+            (TypeArrow (TypeApp (TypeCons ListCon)+                                (TypeVar 0))+                       (TypeApp (TypeCons ListCon)+                                (TypeVar 0))))+  tupleConss <- mapM (\(a,b) -> [(a,y) | y <- unsafeReadType0 b])+    [ (,) (TupleCon 0) "Unit"+    , (,) (TupleCon 2) "a -> b -> (a, b)"+    , (,) (TupleCon 3) "a -> b -> c -> (a, b, c)"+    , (,) (TupleCon 4) "a -> b -> c -> d -> (a, b, c, d)"+    , (,) (TupleCon 5) "a -> b -> c -> d -> e -> (a, b, c, d, e)"+    , (,) (TupleCon 6) "a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f)"+    , (,) (TupleCon 7) "a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g)"+    ]+  return $ consType : tupleConss++builtInDeconstructorsM :: (Monad m) => MultiRWST r w s m [DeconstructorBinding]+builtInDeconstructorsM = mapM helper ds+ where+  helper (t, xs) = [ (x,xs,False)+                   | x <- unsafeReadType0 t+                   ]+  ds = [ (,) "(a, b)" [(TupleCon 2, [TypeVar 0, TypeVar 1])]+       , (,) "(a, b, c)" [(TupleCon 3, [TypeVar 0, TypeVar 1, TypeVar 2])]+       , (,) "(a, b, c, d)" [(TupleCon 4, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3])]+       , (,) "(a, b, c, d, e)" [(TupleCon 5, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4])]+       , (,) "(a, b, c, d, e, f)" [(TupleCon 6, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4, TypeVar 5])]+       , (,) "(a, b, c, d, e, f, g)" [(TupleCon 7, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4, TypeVar 5, TypeVar 6])]+       ]++-- | Takes a list of bindings, and a dictionary of desired+-- functions and their rating, and compiles a list of+-- RatedFunctionBindings.+--+-- If a function in the dictionary is not in the list of bindings,+-- Left is returned with the corresponding name.+--+-- Otherwise, the result is Right.+compileWithDict :: [(QualifiedName, Float)]+                -> [HsFunctionDecl]+                -> Either String [RatedHsFunctionDecl]+                -- function_not_found or all bindings+compileWithDict ratings binds =+  ratings `forM` \(name, rating) ->+    case find ((name==).fst) binds of+      Nothing    -> Left $ show name+      Just (_,t) -> Right (name, rating, t)++-- | input: a list of filenames for haskell modules and the+-- parsemode to use for it.+--+-- output: the environment extracted from these modules, wrapped+-- in a Writer that contains warnings/errors.+parseModules :: forall m r w s+              . ( m ~ MultiRWST r w s IO+                , ContainsType [String] w+                )+             => [(ParseMode, String)]+             -> m+                  ( [HsFunctionDecl]+                  , [DeconstructorBinding]+                  , StaticClassEnv+                  , [QualifiedName]+                  , TypeDeclMap+                  )+parseModules l = do+  rawTuples <- lift $ mapM hRead l+  let eParsed = map hParse rawTuples+  {-+  let h :: Decl -> IO ()+      h i@(InstDecl _ _ _ _ _ _ _) = do+        pprint i >>= print+      h _ = return ()+  forM_ (rights eParsed) $ \(Module _ _ _ _ _ _ ds) ->+    forM_ ds h+  -}+  -- forM_ (rights eParsed) $ \m -> pprintTo 10000 m >>= print+  mapM_ (mTell . (:[])) $ lefts eParsed+  let mods = rights eParsed+  let ds = getDataTypes mods+  typeDeclsE <- getTypeDecls ds mods+  lefts typeDeclsE `forM_` (mTell . (:[]))+  let typeDecls = M.fromList $ (\x -> (tdecl_name x, x)) <$> rights typeDeclsE+  (cntxt@(StaticClassEnv clss insts), n_insts) <- getClassEnv ds typeDecls mods+  -- TODO: try to exfere this stuff+  (decls, deconss) <- do+    stuff <- mapM (hExtractBinds cntxt ds typeDecls) mods+    return $ concat *** concat $ unzip stuff+  let clssNames = fmap tclass_name clss+  let allValidNames = ds ++ clssNames+  let+    dataToBeChecked :: [(String, HsType)]+    dataToBeChecked =+         [ ("the instance data for " ++ show i, t)+         | insts' <- M.elems insts+         , i@(HsInstance _ _ ts) <- insts'+         , t <- ts]+      ++ [ ("the binding " ++ show n, t)+         | (n, t) <- decls]+  let+    check :: String -> HsType -> m ()+    check s t = do+      findInvalidNames allValidNames t `forM_` \n ->+        mTell ["unknown binding '"++show n++"' used in " ++ s]+  dataToBeChecked `forM_` uncurry check+  mTell ["got " ++ show (length clss) ++ " classes"]+  mTell ["and " ++ show (n_insts) ++ " instances"]+  mTell ["(-> " ++ show (length $ concat $ M.elems $ insts) ++ " instances after inflation)"]+  mTell ["and " ++ show (length decls) ++ " function decls"]+  builtInDecls          <- builtInDeclsM+  builtInDeconstructors <- builtInDeconstructorsM+  return $ ( builtInDecls++decls+           , builtInDeconstructors++deconss+           , cntxt+           , allValidNames+           , typeDecls+           )+  where+    hRead :: (ParseMode, String) -> IO (ParseMode, String)+    hRead (mode, s) = (,) mode <$> readFile s+    hParse :: (ParseMode, String) -> Either String Module+    hParse (mode, content) = case parseModuleWithMode mode content of+      f@(ParseFailed _ _) -> Left $ show f+      ParseOk modul       -> Right modul+    hExtractBinds :: StaticClassEnv+                  -> [QualifiedName]+                  -> TypeDeclMap+                  -> Module+                  -> m ([HsFunctionDecl], [DeconstructorBinding])+    hExtractBinds cntxt ds tDeclMap modul@(Module _ (ModuleName _mname) _ _ _ _ _) = do+      -- tell $ return $ mname+      eFromData <- getDataConss (sClassEnv_tclasses cntxt) ds tDeclMap [modul]+      eDecls <- (++)+        <$> getDecls ds (sClassEnv_tclasses cntxt) tDeclMap [modul]+        <*> getClassMethods (sClassEnv_tclasses cntxt) ds tDeclMap [modul]+      mapM_ (mTell . (:[])) $ lefts eFromData ++ lefts eDecls+      -- tell $ map show $ rights ebinds+      let (binds1s, deconss) = unzip $ rights eFromData+          binds2 = rights eDecls+      return $ ( concat binds1s ++ binds2, deconss )++-- | A simplified version of environmentFromModules where the input+-- is just one module, parsed with some default ParseMode;+-- the output is transformed so that all functionsbindings get+-- a rating of 0.0.+parseModulesSimple :: ( ContainsType [String] w+                      )+                   => String+                   -> MultiRWST r w s IO+                        ( [RatedHsFunctionDecl]+                        , [DeconstructorBinding]+                        , StaticClassEnv+                        , [QualifiedName]+                        , TypeDeclMap+                        )+parseModulesSimple s = helper+                   <$> parseModules [(haskellSrcExtsParseMode s, s)]+ where+  addRating (a,b) = (a,0.0,b)+  helper (decls, deconss, cntxt, ds, tdm) = (addRating <$> decls, deconss, cntxt, ds, tdm)++ratingsFromFile :: String -> IO (Either String [(QualifiedName, Float)])+ratingsFromFile = (fmap . first) show . (try :: IO a -> IO (Either SomeException a))+  . fmap (map (\[name, float] -> (parseQualifiedName name, read float)) . chunksOf 2 . words)+  . readFile+++-- TODO: add warnings for ratings not applied+environmentFromModuleAndRatings :: ( ContainsType [String] w+                                   )+                                => String+                                -> String+                                -> MultiRWST r w s IO+                                    ( [FunctionBinding]+                                    , [DeconstructorBinding]+                                    , StaticClassEnv+                                    , [QualifiedName]+                                    , TypeDeclMap+                                    )+environmentFromModuleAndRatings s1 s2 = do+  let exts1 = [ TypeOperators+              , ExplicitForAll+              , ExistentialQuantification+              , TypeFamilies+              , FunctionalDependencies+              , FlexibleContexts+              , MultiParamTypeClasses ]+      exts2 = map EnableExtension exts1+      mode = ParseMode (s1++".hs")+                       Haskell2010+                       exts2+                       False+                       False+                       Nothing+                       False+  (decls, deconss, cntxt, ds, tdm) <- parseModules [(mode, s1)]+  r <- lift $ ratingsFromFile s2+  case r of+    Left e -> do+      mTell ["could not parse ratings!",e]+      return ([], [], cntxt, [], tdm)+    Right ratings -> do+      let f (a,b) = declToBinding+                  $ ( a+                    , fromMaybe 0.0 (lookup a ratings)+                    , b+                    )+      return $ (map f decls, deconss, cntxt, ds, tdm)+++environmentFromPath :: ( ContainsType [String] w+                       )+                    => FilePath+                    -> MultiRWST r w s IO+                         ( [FunctionBinding]+                         , [DeconstructorBinding]+                         , StaticClassEnv+                         , [QualifiedName]+                         , TypeDeclMap+                         )+environmentFromPath p = do+  files <- lift $ getDirectoryContents p+  let modules = ((p ++ "/")++) <$> filter (".hs" `isSuffixOf`) files+  let ratings = ((p ++ "/")++) <$> filter (".ratings" `isSuffixOf`) files+  (decls, deconss, cntxt, dts, tdm) <- parseModules+    [ (mode, m)+    | m <- modules+    , let mode = haskellSrcExtsParseMode m]+  rResult <- lift $ ratingsFromFile `mapM` ratings+  let rs = [x | Right xs <- rResult, x <- xs]+  sequence_ $ do+    Left err <- rResult+    return $ mTell ["could not parse rating file", err]+  (rs' :: [(QualifiedName, Float)]) <- fmap join $ sequence $ do+    (rName, rVal) <- rs+    return $ do+      dIds <- fmap join $ sequence $ do+        (dName, _) <- decls+        return $ do+          return $ do+            guard (show rName == show dName)+            return (dName, rVal)+      case dIds of+        [] -> do+          mTell ["rating could not be applied: " ++ show rName]+          return []+        [x] ->+          return [x]+        _ -> do+          mTell ["duplicate function: " ++ show rName]+          return []+  let f (a,b) = declToBinding+              $ ( a+                , fromMaybe 0.0 (lookup a rs')+                , b+                )+  return $ (map f decls, deconss, cntxt, dts, tdm)

+ src/Language/Haskell/Exference/ExpressionToHaskellSrc.hs view

@@ -0,0 +1,193 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Exference.ExpressionToHaskellSrc+  ( convert+  , convertToFunc+  )+where++++import qualified Language.Haskell.Exference.Core.Expression as E+import qualified Language.Haskell.Exference.Core.Types as T+import qualified Language.Haskell.Exference.Core.TypeUtils as TU+import Language.Haskell.Exts.Syntax++import Control.Monad ( forM )++import Control.Applicative++import qualified Data.Map as M+import Data.Map ( Map )++import Data.HList.ContainsType++import Data.Functor.Identity++import Control.Monad.Trans.MultiState++++-- TODO:+-- 1) merge nested lambdas++-- qualification level -> internal-expression -> haskell-src-expression+-- level 0 = no qualication+-- level 1 = qualification for anything but infix operators+-- level 2 = full qualification (prevents infix operators)+convert :: Int+        -> E.Expression+        -> Exp+convert q e = runIdentity+            $ runMultiStateTNil+            $ withMultiStateA (M.empty :: Map T.TVarId T.HsType)+            $ do+                E.collectVarTypes e+                h e []+  where+    h (E.ExpLambda i ty e1) is = h e1 ((i, ty):is)+    h rhsExp [] = convertExp q rhsExp+    h rhsExp is = [ Lambda noLoc (map (PVar . Ident) params) cr+                  | cr <- convertExp q rhsExp+                  , params <- mapM (T.showTypedVar . fst)+                                   (reverse is)+                  ]++convertToFunc :: Int+              -> String+              -> E.Expression+              -> Decl+convertToFunc q ident e = runIdentity+                        $ runMultiStateTNil+                        $ withMultiStateA (M.empty :: Map T.TVarId T.HsType)+                        $ do+                            E.collectVarTypes e+                            h e []+  where+    h (E.ExpLambda i ty e1) is = h e1 ((i, ty):is)+    h rhsExp is = [ FunBind [Match noLoc+                                   (Ident ident)+                                   (map (PVar . Ident) params)+                                   Nothing+                                   rhs'+                                   Nothing]+                  | rhs' <- UnGuardedRhs <$> convertExp q rhsExp+                  , params <- mapM (T.showTypedVar . fst) (reverse is)+                  ]++-- qualification level -> internal-expression -> haskell-src-expression+-- level 0 = no qualication+-- level 1 = qualification for anything but infix operators+-- level 2 = full qualification (prevents infix operators)+convertExp :: Int -> E.Expression -> MultiState '[Map T.TVarId T.HsType] Exp+convertExp q = convertInternal q 0++parens :: Bool -> Exp -> Exp+parens True e = Paren e+parens False e = e++-- qualification level -> precedence -> expression+-- level 0 = no qualication+-- level 1 = qualification for anything but infix operators+-- level 2 = full qualification (prevents infix operators)+convertInternal+  :: Int -> Int -> E.Expression -> MultiState '[Map T.TVarId T.HsType] Exp+convertInternal _ _ (E.ExpVar i _) = Var . UnQual . Ident+                                    <$> T.showTypedVar i+convertInternal q _ (E.ExpName qn) =+  return $ Con $ UnQual $ Ident $ convertName q qn+convertInternal q p (E.ExpLambda i _ e) =+  [ parens (p>=1) $ Lambda noLoc [PVar $ Ident $ vname] ce+  | ce <- convertInternal q 0 e+  , vname <- T.showTypedVar i+  ]+convertInternal q p (E.ExpApply e1 pe) = recurseApply e1 [pe]+  where+    defaultApply :: E.Expression -> [E.Expression] -> MultiState '[Map T.TVarId T.HsType] Exp+    defaultApply e pes = do+      f  <- convertInternal q 2 e+      ps <- mapM (convertInternal q 3) pes+      return $ parens (p>=3) $ foldl App f ps+    recurseApply :: E.Expression -> [E.Expression] -> MultiState '[Map T.TVarId T.HsType] Exp+    recurseApply (E.ExpApply e1' pe') pes = recurseApply e1' (pe':pes)+    recurseApply e@(E.ExpName qname) pes = do+      case qname of+        T.TupleCon i+          | i==length pes+          , q<2 ->+            Tuple Boxed <$> mapM (convertInternal q 0) pes+        T.Cons+          | q<2+          , [p1, p2] <- pes -> do+              q1 <- convertInternal q 1 p1+              q2 <- convertInternal q 2 p2+              return $ parens (p>=2) $ InfixApp+                q1+                (QVarOp $ UnQual $ Symbol ":")+                q2            +        T.QualifiedName _ ('(':opR)+          | q<2+          , [p1, p2] <- pes -> do+              q1 <- convertInternal q 1 p1+              q2 <- convertInternal q 2 p2+              return $ parens (p>=2) $ InfixApp+                q1+                (QVarOp $ UnQual $ Symbol $ takeWhile (/=')') opR)+                q2+        _ -> defaultApply e pes+    recurseApply e pes = defaultApply e pes+convertInternal _ _ (E.ExpHole i) = return $ Var+                                           $ UnQual+                                           $ Ident+                                           $ "_"++T.showVar i+convertInternal q p (E.ExpLet i _ bindE inE) = do+  rhs <- convertInternal q 0 bindE+  varName <- T.showTypedVar i+  let convBind = PatBind noLoc+                   (PVar $ Ident $ varName)+                   (UnGuardedRhs $ rhs)+                   Nothing+  e <- convertInternal q 0 inE+  return $ parens (p>=2) $ mergeLet convBind e+convertInternal q p (E.ExpLetMatch n ids bindE inE) = do+  rhs <- convertInternal q 0 bindE+  let name = convertName q n+  varNames <- mapM (T.showTypedVar . fst) ids+  let convBind = PatBind noLoc+                   (PParen $ PApp (UnQual $ Ident $ name)+                                  (map (PVar . Ident) varNames))+                   (UnGuardedRhs $ rhs)+                   Nothing+  e <- convertInternal q 0 inE+  return $ parens (p>=2) $ mergeLet convBind e+convertInternal q p (E.ExpCaseMatch bindE alts) = do+  e <- convertInternal q 0 bindE+  as <- alts `forM` \(c, vars, expr) -> do+    rhs <- convertInternal q 0 expr+    let name = convertName q c+    varNames <- mapM (T.showTypedVar . fst) vars+    return $ Alt noLoc+        (PApp (UnQual $ Ident $ name)+              (map (PVar . Ident) varNames))+        (UnGuardedRhs $ rhs)+        Nothing+  return $ parens (p>=2) $ Case e as++convertName :: Int -> T.QualifiedName -> String+convertName d qn = case (d, qn) of+  (0, T.QualifiedName _ n) -> n+  (_, n)                   -> show n++mergeLet :: Decl -> Exp -> Exp+mergeLet convBind (Let (BDecls otherBinds) finalIn)+  = Let (BDecls $ convBind:otherBinds) finalIn+mergeLet convBind finalIn                 +  = Let (BDecls [convBind]) finalIn++noLoc :: SrcLoc+noLoc = SrcLoc "" 0 0

+ src/Language/Haskell/Exference/FunctionDecl.hs view

@@ -0,0 +1,27 @@+{-# LANGUAGE PatternGuards #-}++module Language.Haskell.Exference.FunctionDecl+  ( HsFunctionDecl+  , RatedHsFunctionDecl+  , declToBinding+  )+where++++import Language.Haskell.Exference.Core.FunctionBinding+import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.Core.Expression++++type HsFunctionDecl = (QualifiedName, HsType)+type RatedHsFunctionDecl = (QualifiedName, Float, HsType)+                            -- name, rating, type++declToBinding :: RatedHsFunctionDecl -> FunctionBinding+declToBinding (a,r,t) =+  (result, a, r, constrs, params)+ where+  (result, params, _, constrs) = splitArrowResultParams t

+ src/Language/Haskell/Exference/SimpleDict.hs view

@@ -0,0 +1,213 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE PatternGuards #-}++module Language.Haskell.Exference.SimpleDict+  ( -- defaultBindings+    emptyClassEnv+  -- , defaultClassEnv+  , defaultHeuristicsConfig+  -- , testQueryClassEnv+  -- , typeId+  -- , typeReturn+  -- , typeUnsafe+  -- , typeBind+  -- , typeJoin+  )+where++++import Language.Haskell.Exference.Core ( ExferenceHeuristicsConfig(..) )+import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.FunctionDecl+import Language.Haskell.Exference.TypeDeclsFromHaskellSrc ( unsafeReadType0 )++import qualified Data.Set as S+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IntMap++import Control.Arrow ( second )++-- import Debug.Hood.Observe++++-- typeReturn, typeUnsafe, typeBind, typeJoin, typeId :: HsType+-- typeId     = read "a -> a"+-- typeReturn = read "a -> m a"+-- typeUnsafe = read "a -> b"+-- typeBind   = read "m a -> (a -> m b) -> m b"+-- typeJoin   = read "m (m a) -> m a"++-- toBindings :: [(String, Float, String)] -> [(QualifiedName, Float, HsType)]+-- toBindings = map (\(a,b,c) -> (QualifiedName [] a, b, unsafeReadType0 c))++-- function, penalty for using that function, type+-- value ignored for pattern-matches+-- defaultBindings :: [RatedHsFunctionDecl]+-- defaultBindings = toBindings+--   [+--   -- functor+--     ("fmap",     1.0, "(Functor f) => (a -> b) -> f a -> f b")+--   -- applicative+--   , ("pure",     3.0, "(Applicative f) => a -> f a")+--   , ("(<*>)",    3.0, "(Applicative f) => f (a->b) -> f a -> f b")+--   -- monad+--   , ("(>>=)",    0.0, "(Monad m) => m a -> (a -> m b) -> m b")+--   --, ("(>>)",     8.0, "Monad m => m a -> m b -> m b")+--   -- show+--   , ("show",     3.0, "(Show a) => a -> String")+--   -- eq+--   , ("(==)",     4.0, "Eq a => a -> a -> Bool")+--   , ("(/=)",     10.0, "Eq a => a -> a -> Bool") -- bad, cause same sig as (==)..+--   -- num+--   , ("fromInteger", 9.9, "Num a => Integer -> a")+--   -- real+--   , ("toRational", 9.9, "Real a => a -> Rational")+--   -- integral+--   , ("toInteger", 9.9, "Integral a => a -> Integer")+--   -- fractional+--   , ("fromRational", 9.9, "Fractional a => Rational -> a")+--   -- realfrac+--   , ("truncate", 9.9, "RealFrac a, Integral b => a -> b")+--   , ("round"   , 9.9, "RealFrac a, Integral b => a -> b")+--   , ("ceiling" , 9.9, "RealFrac a, Integral b => a -> b")+--   , ("floor"   , 9.9, "RealFrac a, Integral b => a -> b")+--   -- other+--   , ("(,)",      0.0, "a -> b -> Tuple2 a b")+--   , ("zip",      0.0, "List a -> List b -> List (Tuple2 a b)")+--   , ("repeat",   5.0, "a -> List a")+--   , ("foldr",    0.0, "(a -> b -> b) -> b -> List a -> b")+--   --, ("foldr0",   0.0,  "(a -> List a -> List a) -> a -> List a")+--   , ("()",       9.9, "Unit")+--   , ("State",    3.0, "(s -> Tuple2 a s) -> State s a")+--   , ("[]",       40.0, "List a")+--   , ("(:)",      4.0, "a -> List a -> List a")+--   , ("(,)",      0.0, "Tuple2 a b -> INFPATTERN a b")+--   , ("State",    0.0, "State s a -> INFPATTERN (s -> Tuple2 a s)")+--   , ("Just",     5.0, "a -> Maybe a")+--   , ("sequence", 3.0, "Monad m => List (m a) -> m (List a)")+--   ]++emptyClassEnv :: StaticClassEnv+emptyClassEnv = StaticClassEnv {+  sClassEnv_tclasses = [],+  sClassEnv_instances = M.empty+}++-- defaultClassEnv :: StaticClassEnv+-- defaultClassEnv = mkStaticClassEnv classes instances+--   where+--     classes = [ c_show+--               , c_functor, c_applicative, c_monad+--               , c_eq, c_ord+--               , c_enum+--               , c_num, c_real, c_integral+--               , c_fractional, c_realfrac, c_floating, c_realfloat]+--     instances = inflateInstances+--               $ [ list_show, list_monad, maybe_monad, maybe_show, tuple_show]+--               ++ integral_instances+--               ++ realfloat_instances+-- +-- c_show            = HsTypeClass (QualifiedName [] "Show") [badReadVar "a"] []+-- c_functor         = HsTypeClass (QualifiedName [] "Functor") [badReadVar "f"] []+-- c_applicative     = HsTypeClass (QualifiedName [] "Applicative") [badReadVar "f"]+--                                               [HsConstraint c_functor [read "f"]]+-- c_monad           = HsTypeClass (QualifiedName [] "Monad") [badReadVar "m"]+--                                         [HsConstraint c_applicative [read "m"]]+-- c_monadState      = HsTypeClass+--                       (QualifiedName [] "MonadState")+--                       [badReadVar "s", badReadVar "m"]+--                       [HsConstraint c_monad [read "m"]]+-- c_eq              = HsTypeClass+--                       (QualifiedName [] "Eq")+--                       [badReadVar "a"]+--                       []+-- c_num             = HsTypeClass+--                       (QualifiedName [] "Num")+--                       [badReadVar "a"]+--                       [ HsConstraint c_show [read "a"]+--                       , HsConstraint c_eq [read "a"]]+-- c_ord             = HsTypeClass+--                       (QualifiedName [] "Ord")+--                       [badReadVar "a"]+--                       [HsConstraint c_eq [read "a"]]+-- c_real            = HsTypeClass+--                       (QualifiedName [] "Real")+--                       [badReadVar "a"]+--                       [ HsConstraint c_ord [read "a"]+--                       , HsConstraint c_num [read "a"]]+-- c_fractional      = HsTypeClass+--                       (QualifiedName [] "Fractional")+--                       [badReadVar "a"]+--                       [HsConstraint c_num [read "a"]]+-- c_enum            = HsTypeClass+--                       (QualifiedName [] "Enum")+--                       [badReadVar "a"]+--                       []+-- c_integral        = HsTypeClass+--                       (QualifiedName [] "Integral")+--                       [badReadVar "a"]+--                       [ HsConstraint c_real [read "a"]+--                       , HsConstraint c_enum [read "a"]]+-- c_realfrac        = HsTypeClass+--                       (QualifiedName [] "RealFrac")+--                       [badReadVar "a"]+--                       [ HsConstraint c_real [read "a"]+--                       , HsConstraint c_fractional [read "a"]]+-- c_floating        = HsTypeClass+--                       (QualifiedName [] "Floating")+--                       [badReadVar "a"]+--                       [HsConstraint c_fractional [read "a"]]+-- c_realfloat       = HsTypeClass+--                       (QualifiedName [] "RealFloat")+--                       [badReadVar "a"]+--                       [ HsConstraint c_realfrac [read "a"]+--                       , HsConstraint c_floating [read "a"]]+-- +-- list_show         = HsInstance [HsConstraint c_show [read "a"]] c_show [read "List a"]+-- --list_functor      = HsInstance [] c_functor     [read "List"]+-- --list_applicative  = HsInstance [] c_applicative [read "List"]+-- list_monad        = HsInstance [] c_monad       [read "List"]+-- --maybe_functor     = HsInstance [] c_functor     [read "Maybe"]+-- --maybe_applicative = HsInstance [] c_functor     [read "Maybe"]+-- maybe_monad       = HsInstance [] c_functor     [read "Maybe"]+-- maybe_show        = HsInstance [HsConstraint c_show [read "a"]] c_show [read "Maybe a"]+-- tuple_show        = HsInstance [HsConstraint c_show [read "a"]+--                                ,HsConstraint c_show [read "b"]] c_show [read "Tuple2 a b"]+-- integral_instances  = mkInstances c_integral ["Int", "Integer"]+-- realfloat_instances = mkInstances c_realfloat ["Float", "Double"]+++-- mkInstances :: HsTypeClass -> [String] -> [HsInstance]+-- mkInstances tc strs = map f strs+--   where+--     f s = HsInstance [] tc [read s]++-- testQueryClassEnv = mkQueryClassEnv defaultClassEnv+--     [ HsConstraint c_show [read "v"]+--     , HsConstraint c_show [read "w"]+--     , HsConstraint c_functor [read "x"]+--     , HsConstraint c_monad   [read "y"]+--     , HsConstraint c_monadState [read "s", read "z"]+--     , HsConstraint c_show [read "MyFoo"]+--     , HsConstraint c_show [read "B"]+--     ]++defaultHeuristicsConfig :: ExferenceHeuristicsConfig+defaultHeuristicsConfig = ExferenceHeuristicsConfig+  { heuristics_goalVar               =  4.0+  , heuristics_goalCons              =  0.55+  , heuristics_goalArrow             =  5.0+  , heuristics_goalApp               =  1.9+  , heuristics_stepProvidedGood      =  0.2+  , heuristics_stepProvidedBad       =  5.0+  , heuristics_stepEnvGood           =  6.0+  , heuristics_stepEnvBad            = 22.0+  , heuristics_tempUnusedVarPenalty  =  5.0+  , heuristics_tempMultiVarUsePenalty = 3.0+  , heuristics_functionGoalTransform =  0.0+  , heuristics_unusedVar             = 20.0+  , heuristics_solutionLength        =  0.0153+  }

+ src/Language/Haskell/Exference/TypeDeclsFromHaskellSrc.hs view

@@ -0,0 +1,174 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE PatternGuards #-}++module Language.Haskell.Exference.TypeDeclsFromHaskellSrc+  ( HsTypeDecl (..)+  , TypeDeclMap+  , getTypeDecls+  , convertType+  , convertTypeInternal+  , parseType+  , unsafeReadType+  , unsafeReadType0+  )+where++++import Language.Haskell.Exference.Core.Types+import Language.Haskell.Exference.Core.TypeUtils+import Language.Haskell.Exference.TypeFromHaskellSrc++import Language.Haskell.Exts.Syntax+import qualified Language.Haskell.Exts.Parser as P++import Control.Monad.Trans.MultiRWS+import Data.HList.ContainsType++import Control.Monad.Trans.Either ( runEitherT+                                  , mapEitherT+                                  , EitherT(..)+                                  , hoistEither+                                  , left+                                  )++import Control.Monad ( forM, join, liftM )+import Data.Either ( lefts, rights )+import Data.Bifunctor ( bimap )++import Data.Map ( Map )+import Data.IntMap ( IntMap )+import qualified Data.Map as M+import qualified Data.IntMap as IntMap++++data HsTypeDecl = HsTypeDecl+  { tdecl_name :: QualifiedName+  , tdecl_params :: [TVarId]+  , tdecl_result :: HsType+  } deriving Show -- (Data, Show, Generic, Typeable)++type TypeDeclMap = Map QualifiedName HsTypeDecl++applyTypeDecls :: Map QualifiedName (Either String HsTypeDecl)+               -> HsType +               -> Either String HsType+applyTypeDecls m = go+ where+  go (TypeVar i)      = Right $ TypeVar i+  go (TypeConstant i) = Right $ TypeConstant i+  go t@(TypeCons _)  = goApp [] t+  go (TypeArrow t1 t2) = [ TypeArrow t1' t2'+                         | t1' <- go t1+                         , t2' <- go t2+                         ]+  go (TypeApp l r) = goApp [r] l+  go (TypeForall vars constrs t) = TypeForall vars constrs `liftM` go t+  goApp rs (TypeApp l r)      = goApp (r:rs) l+  goApp rs (TypeCons qn)    = case M.lookup qn m of+    Nothing                  -> foldl TypeApp (TypeCons qn) `liftM` mapM go rs+    Just (Left _)            -> Right $ TypeCons qn -- no need to show the+                                   -- same error multiple times, or is there?+    Just (Right (HsTypeDecl _ vs t))+                             | i <- length vs+                             , i <= length rs+                             -> [ foldl TypeApp substituted pUnchanged+                                | rs' <- mapM go rs+                                , let pAffected = take i rs'+                                , let pUnchanged = drop i rs'+                                , let substs = IntMap.fromList $ zip vs pAffected+                                , let substituted = snd $ applySubsts substs t+                                ]+    _                        -> Left $ "wrong number of parameters for type declaration " ++ show qn+  goApp rs l               = foldl1 TypeApp `liftM` mapM go (l:rs)++getTypeDecls :: ( Monad m+                )+             => [QualifiedName]+             -> [Module]+             -> MultiRWST r w s m [Either String HsTypeDecl]+getTypeDecls ds modules = do+  rawList <- sequence $ do+    Module _loc mn _pragma _warning _mexp _imp decls <- modules+    TypeDecl _loc name rawVars rawTy <- decls+    return $ liftM (bimap (("when parsing type declaration "++show name++": ")++) id)+           $ runEitherT+           $ do+      (ty, tyVarIndex) <- convertTypeNoDecl [] (Just mn) ds rawTy+      let qname = convertModuleName mn name+      -- the 1000 is arbitrary, but it should not be used anyway.+      -- no new type variables should appear on the left hand side.+      vars <- mapEitherT (withMultiStateA (ConvData 1000 tyVarIndex)) $ rawVars `forM` tyVarTransform+      return $ HsTypeDecl qname vars ty+  let converter (HsTypeDecl n vs t) = HsTypeDecl n vs `liftM` applyTypeDecls resultMap t+      resultMap :: Map QualifiedName (Either String HsTypeDecl)+      resultMap = M.map converter+                $ M.fromList+                $ map (\x -> (tdecl_name x, x))+                $ rights rawList+  return $ [ e | e@(Left _) <- rawList ] ++ M.elems resultMap++convertType :: ( Monad m+               )+            => [HsTypeClass]+            -> Maybe ModuleName+            -> [QualifiedName]+            -> TypeDeclMap+            -> Type+            -> EitherT String (MultiRWST r w s m) (HsType, TypeVarIndex)+convertType tcs mn ds declMap t = do+  (ty, index) <- convertTypeNoDecl tcs mn ds t+  ty' <- hoistEither $ applyTypeDecls (M.map Right declMap) ty+  return $ (ty', index)++convertTypeInternal+  :: (MonadMultiState ConvData m)+  => [HsTypeClass]+  -> Maybe ModuleName -- default (for unqualified stuff)+                      -- Nothing uses a broad search for lookups+  -> [QualifiedName] -- list of fully qualified data types+                                         -- (to keep things unique)+  -> TypeDeclMap+  -> Type+  -> EitherT String m HsType+convertTypeInternal tcs defModuleName ds declMap t = do+  ty <- convertTypeNoDeclInternal tcs defModuleName ds t+  ty' <- hoistEither $ applyTypeDecls (M.map Right declMap) ty+  return $ ty'++parseType+  :: (Monad m)+  => [HsTypeClass]+  -> Maybe ModuleName+  -> [QualifiedName]+  -> TypeDeclMap+  -> P.ParseMode+  -> String+  -> EitherT+       String+       (MultiRWST r w s m)+       (HsType, TypeVarIndex)+parseType tcs mn ds tDeclMap m s = case P.parseTypeWithMode m s of+  f@(P.ParseFailed _ _) -> left $ show f+  P.ParseOk t           -> convertType tcs mn ds tDeclMap t++unsafeReadType+  :: (Monad m)+  => [HsTypeClass]+  -> [QualifiedName]+  -> TypeDeclMap+  -> String+  -> MultiRWST r w s m HsType+unsafeReadType tcs ds tDeclMap s = do+  parseRes <- runEitherT $ parseType tcs Nothing ds tDeclMap (haskellSrcExtsParseMode "type") s+  return $ case parseRes of+    Left _ -> error $ "unsafeReadType: could not parse type: " ++ s+    Right (t, _) -> t++unsafeReadType0 :: (Monad m) => String -> MultiRWST r w s m HsType+unsafeReadType0 s = do+  parseRes <- runEitherT $ parseType [] Nothing [] (M.empty) (haskellSrcExtsParseMode "type") s+  return $ case parseRes of+    Left _ -> error $ "unsafeReadType: could not parse type: " ++ s+    Right (t, _) -> t

+ src/Language/Haskell/Exference/TypeFromHaskellSrc.hs view

@@ -0,0 +1,245 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonadComprehensions #-}++module Language.Haskell.Exference.TypeFromHaskellSrc+  ( ConvData(..)+  , convertTypeNoDecl+  , convertTypeNoDeclInternal+  , convertName+  , convertQName+  , convertModuleName+  , getVar+  -- , ConversionMonad+  , parseQualifiedName+  , tyVarTransform+  , haskellSrcExtsParseMode+  , findInvalidNames+  )+where++++import Language.Haskell.Exts.Syntax+import qualified Language.Haskell.Exts.Parser as P++import qualified Language.Haskell.Exference.Core.Types as T+import qualified Language.Haskell.Exference.Core.TypeUtils as TU+import qualified Data.Map as M++import Control.Applicative ( (<$>), (<*>), Applicative, liftA2 )+import Data.Maybe ( fromMaybe )+import Data.List ( find )+import Control.Arrow ( (&&&) )++import Control.Monad.State.Strict+import Control.Monad.Trans.Maybe+import Control.Monad.Identity+import Control.Monad.Trans.Either++import Data.List.Split ( wordsBy )+import Control.Monad.Trans.MultiRWS+import Control.Monad.Trans.MultiState ( MonadMultiState(..) )+import Data.HList.ContainsType++import Language.Haskell.Exts.Extension ( Language (..)+                                       , Extension (..)+                                       , KnownExtension (..) )++import Debug.Trace++++-- type ConversionMonad = EitherT String (State (Int, ConvMap))++data ConvData = ConvData Int T.TypeVarIndex++haskellSrcExtsParseMode :: String -> P.ParseMode+haskellSrcExtsParseMode s = P.ParseMode (s++".hs")+                                      Haskell2010+                                      exts2+                                      False+                                      False+                                      Nothing+                                      False+  where+    exts1 = [ TypeOperators+            , ExplicitForAll+            , ExistentialQuantification+            , TypeFamilies+            , FunctionalDependencies+            , FlexibleContexts+            , MultiParamTypeClasses ]+    exts2 = map EnableExtension exts1++convertTypeNoDecl+  :: Monad m+  => [T.HsTypeClass]+  -> Maybe ModuleName+  -> [T.QualifiedName]+  -> Type+  -> EitherT+       String+       (MultiRWST r w s m)+       (T.HsType, T.TypeVarIndex)+convertTypeNoDecl tcs mn ds t =+  mapEitherT conv $ convertTypeNoDeclInternal tcs mn ds t+ where+  conv m = [ [ (r, index)+             | r <- eith+             ]+           | (eith, ConvData _ index) <- withMultiStateAS (ConvData 0 M.empty) m+           ]++convertTypeNoDeclInternal+  :: (MonadMultiState ConvData m)+  => [T.HsTypeClass]+  -> Maybe ModuleName -- default (for unqualified stuff)+                      -- Nothing uses a broad search for lookups+  -> [T.QualifiedName] -- list of fully qualified data types+                                         -- (to keep things unique)+  -> Type+  -> EitherT String m T.HsType+convertTypeNoDeclInternal tcs defModuleName ds ty = helper ty+ where+  helper (TyFun a b)      = T.TypeArrow+                              <$> helper a+                              <*> helper b+  helper (TyTuple _ ts)   | n <- length ts+                          = foldl T.TypeApp (T.TypeCons $ T.TupleCon n)+                            <$> mapM helper ts+  helper (TyApp a b)      = T.TypeApp+                              <$> helper a+                              <*> helper b+  helper (TyVar vname)    = do+                              i <- getVar vname+                              return $ T.TypeVar i+  helper (TyCon name)     = return+                          $ T.TypeCons+                          $ convertQName defModuleName ds name+  helper (TyList t)       = T.TypeApp (T.TypeCons T.ListCon) <$> helper t+  helper (TyParen t)      = helper t+  helper TyInfix{}        = left "infix operator"+  helper TyKind{}         = left "kind annotation"+  helper TyPromoted{}     = left "promoted type"+  helper (TyForall maybeTVars cs t) =+    T.TypeForall+      <$> case maybeTVars of+            Nothing -> return []+            Just tvs -> tyVarTransform `mapM` tvs+      <*> convertConstraint tcs defModuleName ds `mapM` cs+      <*> helper t+  helper x                = left $ "unknown type element: " ++ show x -- TODO++getVar :: MonadMultiState ConvData m => Name -> m Int+getVar n = do+  ConvData next m <- mGet+  case M.lookup n m of+    Nothing -> do+      mSet $ ConvData (next+1) (M.insert n next m)+      return next+    Just i ->+      return i++-- defaultModule -> potentially-qualified-name-thingy -> exference-q-name+convertQName :: Maybe ModuleName -> [T.QualifiedName] -> QName -> T.QualifiedName+convertQName _ _ (Special UnitCon)          = T.TupleCon 0+convertQName _ _ (Special ListCon)          = T.ListCon+convertQName _ _ (Special FunCon)           = error "no support for FunCon" -- i wonder how we reach this..+convertQName _ _ (Special (TupleCon _ i))   = T.TupleCon i+convertQName _ _ (Special Cons)             = T.Cons+convertQName _ _ (Special UnboxedSingleCon) = T.TupleCon 0+convertQName _ _ (Qual mn s)                = convertModuleName mn s+convertQName (Just d) _ (UnQual s)          = convertModuleName d s+convertQName Nothing ds (UnQual (Ident s))  = fromMaybe (T.QualifiedName [] s)+                                              $ find p ds+ where+  p (T.QualifiedName _ x) = x==s+  p _ = False+convertQName Nothing _ (UnQual s)           = convertName s++convertName :: Name -> T.QualifiedName+convertName (Ident s)  = T.QualifiedName [] s+convertName (Symbol s) = T.QualifiedName [] $ "(" ++ s ++ ")"++convertModuleName :: ModuleName -> Name -> T.QualifiedName+convertModuleName (ModuleName n) (Ident s)  = parseQualifiedName+                                            $ n ++ "." ++ s+convertModuleName (ModuleName n) (Symbol s) = parseQualifiedName+                                            $ "(" ++ n ++ "." ++ s ++ ")"++parseQualifiedName :: String -> T.QualifiedName+parseQualifiedName s = let (prebracket, operator) = span (/='(') s+  in liftA2 T.QualifiedName init last $ wordsBy (=='.') prebracket ++ words operator++convertConstraint+  :: (MonadMultiState ConvData m)+  => [T.HsTypeClass]+  -> Maybe ModuleName+  -> [T.QualifiedName]+  -> Asst+  -> EitherT String m T.HsConstraint+convertConstraint tcs defModuleName@(Just _) ds (ClassA qname types)+  | str    <- convertQName defModuleName ds qname+  , ctypes <- mapM (convertTypeNoDeclInternal tcs defModuleName ds) types+  = do+      ts <- ctypes+      return $ T.HsConstraint ( fromMaybe TU.unknownTypeClass+                              $ find ((==str) . T.tclass_name)+                              $ tcs)+                              ts+convertConstraint tcs Nothing ds (ClassA (UnQual (Symbol "[]")) types)+  | ctypes <- mapM (convertTypeNoDeclInternal tcs Nothing ds) types+  = do+      ts <- ctypes+      return $ T.HsConstraint+                 ( fromMaybe TU.unknownTypeClass+                 $ find ((==T.ListCon) . T.tclass_name)+                 $ tcs )+                 ts+convertConstraint tcs Nothing ds (ClassA (UnQual (Ident name)) types)+  | ctypes <- mapM (convertTypeNoDeclInternal tcs Nothing ds) types+  = do+      ts <- ctypes+      let tcsTuples = (\tc -> (T.tclass_name tc, tc)) <$> tcs+      let searchF (T.QualifiedName _ n) = n==name+          searchF _                     = False+      let tc = fromMaybe TU.unknownTypeClass+             $ snd <$> find (searchF . fst) tcsTuples+      return $ T.HsConstraint tc ts+convertConstraint tcs _ ds (ClassA q@(Qual {}) types)+  | ctypes <- mapM (convertTypeNoDeclInternal tcs Nothing ds) types+  , name <- convertQName Nothing ds q+  = do+      ts <- ctypes+      return $ T.HsConstraint+                 ( fromMaybe TU.unknownTypeClass+                 $ find (\(T.HsTypeClass n _ _)+                         -> n==name) tcs+                 )+                 ts+convertConstraint _ Nothing _ cls@ClassA{} = error $ "convertConstraint" ++ show cls+convertConstraint env defModuleName ds (ParenA c)+  = convertConstraint env defModuleName ds c+convertConstraint _ _ _ c+  = left $ "bad constraint: " ++ show c++tyVarTransform :: MonadMultiState ConvData m+               => TyVarBind+               -> EitherT String m T.TVarId+tyVarTransform (KindedVar _ _) = left $ "KindedVar"+tyVarTransform (UnkindedVar n) = getVar n++findInvalidNames :: [T.QualifiedName] -> T.HsType -> [T.QualifiedName]+findInvalidNames _ T.TypeVar {}          = []+findInvalidNames _ T.TypeConstant {}     = []+findInvalidNames valids (T.TypeCons qn) = case qn of+    n@(T.QualifiedName _ _) -> [ n | n `notElem` valids ]+    _                       -> []+findInvalidNames valids (T.TypeArrow t1 t2)   =+  findInvalidNames valids t1 ++ findInvalidNames valids t2+findInvalidNames valids (T.TypeApp t1 t2)     =+  findInvalidNames valids t1 ++ findInvalidNames valids t2+findInvalidNames valids (T.TypeForall _ _ t1) =+  findInvalidNames valids t1