diff --git a/CGI.lhs b/CGI.lhs new file mode 100644 --- /dev/null +++ b/CGI.lhs @@ -0,0 +1,14 @@ +#!/usr/bin/runhaskell + +Compile with +ghc -O CGI.lhs -o MagicHaskeller-exp.cgi -package cgi -package mueval -package hint --make -DGHC7 + +Also, timeout has to be implemented! + +\begin{code} +module Main(main) where +import MagicHaskeller.CGI +import Network.CGI + +main = main' runCGI +\end{code} diff --git a/Control/Monad/Search/Combinatorial.lhs b/Control/Monad/Search/Combinatorial.lhs --- a/Control/Monad/Search/Combinatorial.lhs +++ b/Control/Monad/Search/Combinatorial.lhs @@ -206,15 +206,14 @@ scanlRc :: (Bag a -> Bag b -> Bag a) -> Bag a -> Recomp b -> Recomp a scanlRc f xs rc = result where result = xs `consRc` zipDepth3Rc (\_ -> f) result rc -getDepth :: Recomp Int -getDepth = Rc (\d -> [d]) - -- making delay apart to implement zipWithConsFMT. class Delay m where delay :: m a -> m a delay = ndelay 1 ndelay :: Int -> m a -> m a ndelay n x = iterate delay x !! n + getDepth :: m Int + instance Delay DepthFst where delay = id ndelay _ = id @@ -223,10 +222,14 @@ g n = f (n-1) ndelay i (Rc f) = Rc g where g n | n < i = mempty | otherwise = f (n-i) + getDepth = Rc (\d -> [d]) + instance Delay Matrix where delay (Mx xm) = Mx (mempty:xm) ndelay 0 mx = mx ndelay i mx = delay $ ndelay (i-1) mx + getDepth = fromRc getDepth + instance Monad m => Delay (RecompT m) where delay (RcT f) = RcT g where g 0 = return mempty g n = f (n-1) @@ -378,6 +381,7 @@ delay (DB p) = DB $ \n -> case n of 0 -> [] n -> p (n-1) ndelay i (DB p) = DB $ \n -> if n [ (d, n-d) | d <- [0..n] ] instance Monad m => Delay (DBoundT m) where delay (DBT p) = DBT $ \n -> case n of 0 -> return [] n -> p (n-1) diff --git a/Data/Memo.hs b/Data/Memo.hs --- a/Data/Memo.hs +++ b/Data/Memo.hs @@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE CPP, RankNTypes #-} module Data.Memo where import Data.Char(ord,chr) import Data.Bits @@ -123,9 +123,9 @@ appInteger :: MapInteger a -> Integer->a appInteger = appLargeIntegral (fromIntegral (minBound::Int), fromIntegral (maxBound::Int)) data MapLargeIntegral i a = MLI (MapIntegral a) (i->a) -memoLargeIntegral :: Bits i => (i->a) -> MapLargeIntegral i a +memoLargeIntegral :: (Bits i, Num i) => (i->a) -> MapLargeIntegral i a memoLargeIntegral f = MLI (memoIntegral f) f -appLargeIntegral :: (Bits i, Ord i) => (i,i) -- ^ range +appLargeIntegral :: (Bits i, Ord i, Num i) => (i,i) -- ^ range -> MapLargeIntegral i a -> i->a appLargeIntegral (minb,maxb) (MLI mi f) i | minb <= i && i <= maxb = appIntegral mi i | otherwise = f i @@ -139,14 +139,14 @@ nonnegArrow :: MapNat a } type MapNat = MapFiniteList MapBool -memoIntegral :: Bits i => (i -> a) -> MapIntegral a +memoIntegral :: (Bits i, Num i) => (i -> a) -> MapIntegral a memoIntegral f = MI (memoPosNat (\n -> f (-n))) (memoPosNat (\n -> f (n-1))) memoPosNat f = memoFiniteList memoBool (\bs -> f (bitsToPosNat bs)) bitsToPosNat [] = 1 bitsToPosNat (b:bs) | b = gbs .|. 1 | otherwise = gbs where gbs = bitsToPosNat bs `shiftL` 1 -appIntegral :: Bits i => MapIntegral a -> (i->a) +appIntegral :: (Bits i, Num i) => MapIntegral a -> (i->a) appIntegral (MI n nn) i | signum i == -1 = appPosNat n (-i) | otherwise = appPosNat nn (i+1) appPosNat m i = appFiniteList appBool m (posNatToBits i) diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal --- a/MagicHaskeller.cabal +++ b/MagicHaskeller.cabal @@ -1,6 +1,6 @@ Name: MagicHaskeller -Version: 0.9.1 -Cabal-Version: >= 1.2 +Version: 0.9.6.4.1 +Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE Author: Susumu Katayama @@ -11,10 +11,15 @@ Synopsis: Automatic inductive functional programmer by systematic search Build-Type: Simple Category: Language -data-files: ExperimIOP.hs --- Tested-with: GHC == 6.10.4 -Tested-with: GHC == 6.12.1 +data-files: ExperimIOP.hs MagicHaskeller/predicates MagicHaskeller/predicatesAug2014 MagicHaskeller.conf MagicHaskeller/predicatesServed +Extra-source-files: xlmap +-- Tested-with: GHC == 6.12.1 +Tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.4 +Flag TFRANDOM + Description: Use the tf-random package instead of the random package + Default: True + Flag GHCAPI Description: Enable execution using the GHC API rather than the combinatory interpreter Default: True @@ -27,14 +32,22 @@ Description: Enable to read a component library file Default: True +Flag DEBUG + Description: Force typechecking at each dynamic application + Default: False + +Flag NETWORKURI + Description: Find Network.URI in network-uri rather than network < 2.6 (This is a workaround for the changes made in those packages.) + Default: True + -- Flag ForcibleTO -- Flag Debug -- Flag Benchmark Library - Build-depends: old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, network, pretty + Build-depends: old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable Exposed-modules: MagicHaskeller, Control.Monad.Search.Combinatorial, Control.Monad.Search.Best, MagicHaskeller.ProgGen, MagicHaskeller.ProgGenSF, - MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options, MagicHaskeller.Classification, MagicHaskeller.GetTime, MagicHaskeller.Minimal, MagicHaskeller.IOGenerator + MagicHaskeller.ProgGenSFIORef, MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options, MagicHaskeller.Classification, MagicHaskeller.GetTime, MagicHaskeller.Minimal, MagicHaskeller.IOGenerator, MagicHaskeller.FastRatio, MagicHaskeller.LibExcel Other-modules: MagicHaskeller.MemoToFiles, MagicHaskeller.ShortString, MagicHaskeller.Types, MagicHaskeller.PriorSubsts, Data.Memo, MagicHaskeller.ClassifyTr, MagicHaskeller.CoreLang, MagicHaskeller.DebMT, MagicHaskeller.TyConLib, @@ -44,11 +57,17 @@ MagicHaskeller.ExprStaged, MagicHaskeller.Combinators, MagicHaskeller.ReadDynamic, MagicHaskeller.MyDynamic, MagicHaskeller.ClassifyDM, MagicHaskeller.ProgramGenerator, MagicHaskeller.Analytical.FMExpr, MagicHaskeller.Analytical.Parser, MagicHaskeller.Analytical.Syntax, MagicHaskeller.Analytical.UniT, MagicHaskeller.Analytical.Synthesize, - MagicHaskeller.ExpToHtml + MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged + MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged, MagicHaskeller.LibExcelStagedStaged + Paths_MagicHaskeller Extensions: CPP, TemplateHaskell GHC-options: -O2 -fvia-C - cpp-options: -DCHTO + cpp-options: -DCHTO -DCABAL + if flag(TFRANDOM) + Build-depends: tf-random <= 0.3 + cpp-options: -DTFRANDOM + if flag(GHCAPI) && !os(windows) Build-depends: ghc >= 6.10, ghc-paths Exposed-modules: MagicHaskeller.RunAnalytical, MagicHaskeller.ExecuteAPI610 @@ -58,6 +77,63 @@ cpp-options: -DHASKELLSRC Other-modules: MagicHaskeller.ReadHsType - if flag(GHC7) - Build-depends: ghc >= 7 - cpp-options: -DGHC7 + if flag(DEBUG) + cpp-options: -DREALDYNAMIC + + if flag(NETWORKURI) + Build-depends: network >= 2.6, network-uri >= 2.6 + else + Build-depends: network < 2.6, network-uri < 2.6 + +Executable MagicHaskeller + Main-is: MagicHaskeller/SimpleServer.hs + Build-depends: MagicHaskeller, old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, process, monad-par, transformers, abstract-par, ghc-paths, ghc + GHC-options: -threaded -feager-blackholing -rtsopts + -- In my experience we should never use -O2 here --- it causes memory leak when compiled with GHC 7.6.3. + Extensions: CPP, TemplateHaskell + cpp-options: -DCHTO -DCABAL + + if !os(windows) + Build-depends: unix + cpp-options: -DUNIX + + if flag(TFRANDOM) + Build-depends: tf-random + cpp-options: -DTFRANDOM + + -- just for avoiding rebuilding everything + if flag(READFILE) + Build-depends: haskell-src + cpp-options: -DHASKELLSRC + + if flag(GHC7) + Build-depends: ghc >= 7 + GHC-options: -with-rtsopts=-N + + if flag(NETWORKURI) + Build-depends: network >= 2.6, network-uri >= 2.6 + else + Build-depends: network < 2.6, network-uri < 2.6 + +-- It is strongly recommended to use a UNIX server for the CGI frontend. +-- Non-UNIX servers cannot use mueval, which means the functionality of generating input/output examples is not available. +Executable MagicHaskeller.cgi + Main-is: CGI.lhs + Build-depends: old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, + MagicHaskeller, cgi, hint, extensible-exceptions, haskell-src + Other-modules: MagicHaskeller.CGI + + cpp-options: -DCHTO -DCABAL + + if !os(windows) + Build-depends: mueval + cpp-options: -DUNIX + + if flag(TFRANDOM) + Build-depends: tf-random + cpp-options: -DTFRANDOM + + if flag(NETWORKURI) + Build-depends: network >= 2.6, network-uri >= 2.6 + else + Build-depends: network < 2.6, network-uri < 2.6 diff --git a/MagicHaskeller.conf b/MagicHaskeller.conf new file mode 100644 --- /dev/null +++ b/MagicHaskeller.conf @@ -0,0 +1,10 @@ +C { + computerLanguage = LHaskell, + portID = PortNumber 55444, + hostname = "localhost", + maximalDepth = 7, + myPath = "/cgi-bin/", + minimalDepth = 3, + pagesize = 30, + needSignature = False + } diff --git a/MagicHaskeller.lhs b/MagicHaskeller.lhs --- a/MagicHaskeller.lhs +++ b/MagicHaskeller.lhs @@ -4,7 +4,7 @@ \begin{code} -{-# OPTIONS -fglasgow-exts -XTemplateHaskell -cpp #-} +{-# LANGUAGE TemplateHaskell, CPP, MagicHash, Rank2Types #-} module MagicHaskeller( -- * Re-exported modules -- | This library implicitly re-exports the entities from @@ -20,7 +20,7 @@ -- ** Class for program generator algorithms -- | Please note that @ConstrL@ and @ConstrLSF@ are obsoleted and users are expected to use the 'constrL' option in 'Option'. ProgramGenerator, - ProgGen, ProgGenSF, + ProgGen, ProgGenSF, ProgGenSFIORef, -- ** Functions for creating your program generator algorithm -- | You can set your primitives like, e.g., @'setPrimitives' $('p' [| ( (+) :: Int->Int->Int, 0 :: Int, \'A\', [] :: [a] ) |])@, @@ -55,8 +55,12 @@ -- second element the second greatest priority, and so on. mkPGX, mkPGXOpt, + mkPGXOpts, Options, Opt(..), options, MemoType(..), + -- | These are versions for 'ProgramGeneratorIO'. + mkPGIO, mkPGXOptIO, + #ifdef HASKELLSRC -- *** Alternative way to create your program generator algorithm -- | 'load' and 'f' provides an alternative scheme to create program generator algorithms. @@ -111,14 +115,17 @@ stripEvery, -- ** Pretty printers - pprs, pprsIO, pprsIOn, lengths, lengthsIO, lengthsIOn, printQ, + pprs, pprsIO, pprsIOn, lengths, lengthsIO, lengthsIOn, lengthsIOnLn, printQ, -- * Internal data representation -- | The following types are assigned to our internal data representations. Primitive, HValue(HV), +#ifdef PAR + fpartialParIO, mapParIO, +#endif -- other stuff which will not be documented by Haddock - unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable + unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable, zipAppend, mapIO, fpIO, fIO, fpartial, fpartialIO, etup, mkCurriedDecls ) where import Data.Generics(everywhere, mkT, Data) @@ -139,6 +146,7 @@ import MagicHaskeller.ProgGen(ProgGen(PG)) import MagicHaskeller.ProgGenSF(ProgGenSF, PGSF) +import MagicHaskeller.ProgGenSFIORef(ProgGenSFIORef, PGSFIOR) -- import MagicHaskeller.ProgGenLF(ProgGenLF) -- import MagicHaskeller.ProgGenXF(ProgGenXF) import MagicHaskeller.ProgramGenerator @@ -150,7 +158,11 @@ import GHC.Exts(unsafeCoerce#) -- import Maybe(fromJust) import System.IO +#ifdef TFRANDOM +import System.Random.TF(seedTFGen,TFGen) +#else import System.Random(mkStdGen,StdGen) +#endif import MagicHaskeller.MHTH import MagicHaskeller.TimeOut @@ -164,10 +176,35 @@ import MagicHaskeller.Instantiate(mkRandTrie) import MagicHaskeller.MemoToFiles(MemoType(..)) +import Data.List(genericLength) + +-- import Control.Concurrent.ParallelIO(parallelInterleaved) +import MagicHaskeller.DebMT(interleaveActions) +#ifdef PAR +import Control.Monad.Par.IO +import Control.Monad.Par.Class +import Control.Monad.IO.Class(liftIO) +#endif + +import Control.Concurrent.MVar +import Control.Concurrent + \end{code} \begin{code} +mkCurriedDecls :: String -> ExpQ -> ExpQ -> DecsQ +mkCurriedDecls tag funq eq = do e <- eq + fun <- funq + case e of TupE es -> fmap concat $ mapM (mcd fun) es + _ -> mcd fun e + where mcd :: Exp -> Exp -> DecsQ + mcd fun v@(VarE name) = let nb = nameBase name + in return [ValD (VarP $ mkName $ nb++tag) (NormalB (AppE fun v)) []] +-- where mcd :: Exp -> DecsQ +-- mcd v@(VarE name) = let nb = nameBase name +-- in [d| $(return $ VarP $ mkName $ nb++tag) = $(funq) $(return v) |] + -- "MemoDeb" name should be hidden, or maybe I could rename it. -- | 'define' eases use of this library by automating some function definitions. For example, @@ -226,12 +263,9 @@ p1' e e ty p1 e@(VarE name) = do VarI _ ty _ _ <- reify name p1' e e ty -p1 e = do ee <- expToExpExp e - return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) e), ee, AppE (VarE (mkName "trToTHType")) (AppE (VarE (mkName "typeOf")) e)] +p1 e = [| (HV (unsafeCoerce# $(return e)), $(expToExpExp e), trToTHType (typeOf $(return e))) |] -p1' se e ty = do ee <- expToExpExp e - et <- typeToExpType ty - return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) se), ee, et] +p1' se e ty = [| (HV (unsafeCoerce# $(return se)), $(expToExpExp e), $(typeToExpType ty)) |] -- nameToExpName :: TH.Name -> TH.Exp -- nameToExpName = strToExpName . showName @@ -258,9 +292,9 @@ primitivesp :: TyConLib -> [[Primitive]] -> [[Typed [CoreExpr]]] primitivesp tcl pss - = let ixs = scanl (+) 0 $ map length pss + = let ixs = scanl (+) 0 $ map genericLength pss in zipWith (\ix -> mergesortWithBy (\(x:::t) (y:::_) -> (x++y):::t) (\(_:::t) (_:::u) -> compare t u) . - zipWith (\ n (_,e,ty) -> [Primitive n $ expIsAConstr e] ::: thTypeToType tcl ty) [ix..]) ixs pss + zipWith (\ n (_,e,ty) -> [if expIsAConstr e then PrimCon n else Primitive n] ::: toCxt (numCxts e) (thTypeToType tcl ty)) [ix..]) ixs pss -- See if the argument is a constructor expression. expIsAConstr (ConE _) = True @@ -271,20 +305,31 @@ expIsAConstr (InfixE (Just _) (ConE _) (Just _)) = True expIsAConstr _ = False +numCxts (VarE nm) = case nameBase nm of 'b':'y':d:'_':_ | isDigit d -> digitToInt d + '-':'-':xs@('#':_) -> length $ takeWhile (=='#') xs + _ -> 0 +numCxts _ = 0 +toCxt 0 t = t +toCxt n (t :-> u) = t :=> toCxt (n-1) u +primitivesc :: TyConLib -> [Primitive] -> [Typed [CoreExpr]] +primitivesc tcl ps = mergesortWithBy (\(x:::t) (y:::_) -> (x++y):::t) (\(_:::t) (_:::u) -> compare t u) $ + map (\ (HV x,e,thty) -> let ty = thTypeToType tcl thty + in [Context $ Dict $ PD.unsafeToDyn tcl ty x e] ::: {- toCxt (numCxts e) -} ty) ps mkPG :: ProgramGenerator pg => [Primitive] -> pg -mkPG = mkPGX . (:[]) -mkPGX :: ProgramGenerator pg => [[Primitive]] -> pg +mkPG = mkPGX [] . (:[]) +mkPGX :: ProgramGenerator pg => [Primitive] -> [[Primitive]] -> pg mkPGX = mkPG' True -- ^ 'mkPG' is defined as: -- -- > mkPG prims = mkPGSF (mkStdGen 123456) (repeat 5) prims prims mkMemo :: ProgramGenerator pg => [Primitive] -> pg -mkMemo = mkPG' False . (:[]) -mkPG' :: ProgramGenerator pg => Bool -> [[Primitive]] -> pg -mkPG' cont tups = case mkCommon options{contain=cont} $ concat tups of cmn -> mkTrie cmn (primitivesp (tcl cmn) tups) +mkMemo = mkPG' False [] . (:[]) +mkPG' :: ProgramGenerator pg => Bool -> [Primitive] -> [[Primitive]] -> pg +mkPG' cont classes tups = case mkCommon options{contain=cont} totals totals of cmn -> mkTrie cmn (primitivesc (tcl cmn) classes) (primitivesp (tcl cmn) tups) + where totals = concat tups ++ classes -- | 'mkPGSF' and 'mkMemoSF' are provided mainly for backward compatibility. These functions are defined only for the 'ProgramGenerator's whose names end with @SF@ (i.e., generators with synergetic filtration). -- For such generators, they are defined as: @@ -293,26 +338,43 @@ -- > mkMemoSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = False, stdgen = gen, nrands = nrnds}) tups mkPGSF,mkMemoSF :: ProgramGenerator pg => +#ifdef TFRANDOM + TFGen +#else StdGen +#endif -> [Int] -- ^ number of random samples at each depth, for each type. -> [Primitive] + -> [Primitive] -> [Primitive] -> pg mkPGSF = mkPGSF' True mkMemoSF = mkPGSF' False -mkPGSF' cont gen nrnds optups tups = mkPGOpt (options{primopt = Just [optups], contain = cont, stdgen = gen, nrands = nrnds}) tups +mkPGSF' cont gen nrnds classes optups tups = mkPGOpt (options{primopt = Just [optups], contain = cont, stdgen = gen, nrands = nrnds}) classes tups -- Currently only the pg==ConstrLSF case makes sense. ¤Ã¤Æ¤Î¤Ï¡¤optups¤Î¤ß¤Ë´Ø¤¹¤ëÏäǡ¤rnds¤Ï´Ø·¸¤Ê¤¤¡¥ -mkPG075 :: ProgramGenerator pg => [Primitive] -> pg +mkPG075 :: ProgramGenerator pg => [Primitive] -> [Primitive] -> pg mkPG075 = mkPGOpt (options{primopt = Nothing, contain = True, guess = True}) -mkMemo075 :: ProgramGenerator pg => [Primitive] -> pg +mkMemo075 :: ProgramGenerator pg => [Primitive] -> [Primitive] -> pg mkMemo075 = mkPGOpt (options{primopt = Nothing, contain = False, guess = True}) -mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> pg -mkPGOpt opt = mkPGXOpt opt . (:[]) -mkPGXOpt :: ProgramGenerator pg => Options -> [[Primitive]] -> pg -mkPGXOpt opt prims = case mkCommon opt $ concat prims of cmn -> mkTrieOpt cmn (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) prims) +mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> [Primitive] -> pg +mkPGOpt opt classes prims = mkPGXOpt opt classes [] [prims] [] +mkPGXOpt :: ProgramGenerator pg => Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> pg +mkPGXOpt = mkPGXOpts mkTrieOpt +mkPGIO :: ProgramGeneratorIO pg => [Primitive] -> [Primitive] -> IO pg +mkPGIO classes prims = mkPGXOptIO options classes [] [prims] [] +mkPGXOptIO :: ProgramGeneratorIO pg => Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> IO pg +mkPGXOptIO = mkPGXOpts mkTrieOptIO + +mkPGXOpts mkt opt classes partclasses prims partprims = case mkCommon opt (concat totalss ++ totalclss) (concat partialss ++ partialclss) of cmn -> mkt cmn (primitivesc (tcl cmn) totalclss) (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) totalss) where primsOpt = case primopt opt of Nothing -> prims Just po -> po + (tot, part) = unzip $ map unzip partprims + totalss = zipAppend prims tot + partialss = zipAppend prims part + (totc,partc)= unzip partclasses + totalclss = classes ++ totc + partialclss = classes ++ partc setPG :: ProgGen -> IO () @@ -320,11 +382,17 @@ -- | @setPrimitives@ creates a @ProgGen@ from the given set of primitives using the current set of options, and sets it as the current program generator. -- It used to be equivalent to @setPG . mkPG@ which overwrites the options with the default, but it is not now. -setPrimitives :: [Primitive] -> IO () -setPrimitives tups = do PG (x,y,cmn) <- readIORef refmemodeb - setPG $ mkPGOpt ((opt cmn){primopt=Nothing}) tups +setPrimitives :: [Primitive] -> [Primitive] -> IO () +setPrimitives classes tups = do PG (_,_,_,cmn) <- readIORef refmemodeb + setPG $ mkPGOpt ((opt cmn){primopt=Nothing}) classes tups -- setPrimitives tups = writeIORef refmemodeb (mkPG tups) -- This definition overwrites the old configuration. +-- zipAppend is like zipWith (++), but the length of the resulting list is the same as that of the longer of the two list arguments. +zipAppend :: [[a]] -> [[a]] -> [[a]] +zipAppend [] yss = yss +zipAppend xss [] = xss +zipAppend (xs:xss) (ys:yss) = (xs++ys) : zipAppend xss yss + #ifdef HASKELLSRC -- | 'load' loads a component library file. load :: FilePath @@ -341,17 +409,17 @@ setTimeout :: Int -- ^ time in microseconds -> IO () setTimeout n = do pto <- newPTO n - PG (x,y,cmn) <- readIORef refmemodeb - writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Just pto}}) + PG (x,y,z,cmn) <- readIORef refmemodeb + writeIORef refmemodeb $ PG (x,y,z,cmn{opt = (opt cmn){timeout=Just pto}}) -- | 'unsetTimeout' disables timeout. This is the safe choice. unsetTimeout :: IO () -unsetTimeout = do PG (x,y,cmn) <- readIORef refmemodeb - writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Nothing}}) +unsetTimeout = do PG (x,y,z,cmn) <- readIORef refmemodeb + writeIORef refmemodeb $ PG (x,y,z,cmn{opt = (opt cmn){timeout=Nothing}}) setDepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space). -> IO () -setDepth d = do PG (x,y,cmn) <- readIORef refmemodeb - writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){memodepth=d}}) +setDepth d = do PG (x,y,z,cmn) <- readIORef refmemodeb + writeIORef refmemodeb $ PG (x,y,z,cmn{opt = (opt cmn){memodepth=d}}) -- ^ Currently the default depth is 10. You may want to lower the value if your computer often swaps, or increase it if you have a lot of memory. @@ -373,19 +441,25 @@ trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates. trsToTCstrs [] = [] -trsToTCstrs (tr:ts) = case splitTyConApp tr of (tc,trs) -> (length trs, tyConString tc) : trsToTCstrs (trs++ts) +trsToTCstrs (tr:ts) = case splitTyConApp tr of (tc,trs) -> (length trs, tyConName tc) : trsToTCstrs (trs++ts) -- Memo¤ägetEverything¼«ÂΤÏIORef¤ò»È¤ï¤º¤ËIO¤Ê¤·¤Ç¼ÂÁõ¤Ç¤­¤ëÌõ¤Ç¡¤¤½¤Î°ÕÌ£¤Ç¤Ï¡¤IORef¤ò»È¤ï¤Ê¤¤Êý¤¬¤¤¤¤¤«¤â¡¥ -- x ¤Ä¤¤¤Ç¤Ë¤¤¤¦¤È¡¤1ÉäǤΥ¿¥¤¥à¥¢¥¦¥È¤òɽ¤¹PTO¡Ê¤ÎGLOBAL_VAR¡Ë¤âIO¤Ê¤·¤ÇÍѰդǤ­¤ë¡¥¡ÊunsafePerformIO»È¤¦¤±¤É¡Ë -- | 'getEverything' uses the \'global\' values set with @set*@ functions. 'getEverythingF' is its filtered version -getEverything :: Typeable a => IO (Every a) -getEverything = do memodeb <- readIORef refmemodeb - return (everything memodeb) -getEverythingF :: Typeable a => IO (Every a) -getEverythingF =do memodeb <- readIORef refmemodeb - return (everythingF memodeb) +getEverything :: Typeable a => + Bool -- ^ whether to include functions with unused arguments + -> IO (Every a) +getEverything withAbsents = do + memodeb <- readIORef refmemodeb + return (everything memodeb withAbsents) +getEverythingF :: Typeable a => + Bool -- ^ whether to include functions with unused arguments + -> IO (Every a) +getEverythingF withAbsents = do + memodeb <- readIORef refmemodeb + return (everythingF memodeb withAbsents) {- getEverything = result where ty = typeOf $ snd $ head $ head $ unsafePerformIO result @@ -398,6 +472,7 @@ -- 'everythingF' is its filtered version everything, everythingF :: (ProgramGenerator pg, Typeable a) => pg -- ^ program generator + -> Bool -- ^ whether to include functions with unused arguments -> Every a everything memodeb = et undefined memodeb (mxExprToEvery "MagicHaskeller.everything: type mismatch" memodeb) everythingF memodeb = et undefined memodeb (mxExprFiltEvery "MagicHaskeller.everythingF: type mismatch" memodeb) @@ -405,43 +480,63 @@ a -- ^ dummy argument -> pg -- ^ program generator -> (Types.Type -> Matrix AnnExpr -> Matrix (Exp, a)) + -> Bool -- ^ whether to include functions with unused arguments -> Every a -et dmy memodeb filt = unMx $ filt ty $ matchingPrograms ty memodeb +et dmy memodeb filt withAbsents = unMx $ filt ty $ matchPs withAbsents ty memodeb where ty = trToType (extractTCL memodeb) (typeOf dmy) noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a noFilter _m _t = id -mxExprToEvery :: (Expression e, Search m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a) -mxExprToEvery msg memodeb _ = fmap (unwrapAE msg memodeb . toAnnExpr (reducer memodeb)) -mxExprFiltEvery :: (Expression e, FiltrableBF m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a) -mxExprFiltEvery msg memodeb ty = fmap (unwrapAE msg memodeb) . randomTestFilter memodeb ty . fmap (toAnnExpr (reducer memodeb)) +matchPs True = matchingPrograms +matchPs False = matchingProgramsWOAbsents -unwrapAE :: (ProgramGenerator pg, Typeable a) => String -> pg -> AnnExpr -> (Exp, a) -unwrapAE msg memodeb (AE e dyn) = (exprToTHExp (extractVL memodeb) e, fromDyn tcl dyn (error msg)) +mxExprToEvery :: (Expression e, Search m, WithCommon pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a) +mxExprToEvery msg memodeb _ = fmap (unwrapAE (extractVL memodeb) msg memodeb . toAnnExpr (reducer $ extractCommon memodeb)) +mxExprFiltEvery :: (Expression e, FiltrableBF m, WithCommon pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a) +mxExprFiltEvery msg memodeb ty = fmap (unwrapAE (extractVL memodeb) msg memodeb) . randomTestFilter memodeb ty . fmap (toAnnExpr (reducer $ extractCommon memodeb)) + +unwrapAE :: (WithCommon pg, Typeable a) => VarLib -> String -> pg -> AnnExpr -> (Exp, a) +unwrapAE vl msg memodeb (AE e dyn) = (exprToTHExp vl e, fromDyn tcl dyn (error msg)) where tcl = extractTCL memodeb + + +etup :: (ProgramGenerator pg, Typeable a) => + a -- ^ dummy argument + -> pg -- ^ program generator + -> Bool -- ^ whether to include functions with unused arguments + -> [[((Exp,a), (Exp,a))]] +etup dmy memodeb withAbsents + = unMx + $ fmap (\e -> (unwrapAE (vl cmn) "MagicHaskeller.etup: type mismatch" memodeb $ toAnnExpr (execute (opt cmn) (vl cmn)) e, + unwrapAE (pvl cmn) "MagicHaskeller.etup: type mismatch" memodeb $ toAnnExpr (execute (opt cmn) (pvl cmn)) $ toCE e)) + $ matchPs withAbsents ty memodeb + where ty = trToType (extractTCL memodeb) (typeOf dmy) + cmn = extractCommon memodeb {- ̵¸Â¥ê¥¹¥È¤ò»È¤¦¤Ê¤é¡¤unsafeInterleaveIO¤¬É¬ÍפʤϤº¡¥¤½¤Î¾ì¹çIO¤ËÆò½¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥ -} everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) => pg -- ^ program generator + -> Bool -- ^ whether to include functions with unused arguments -> Int -- ^ query depth -> m [(TH.Exp, a)] everythingM = eM undefined eM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) => a -- ^ dummy argument -> pg -- ^ program generator + -> Bool -- ^ whether to include functions with unused arguments -> Int -> m [(TH.Exp, a)] -eM dmy memodeb = result +eM dmy memodeb withAbsents = result where tcl = extractTCL memodeb ty = trToType tcl $ typeOf dmy - result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchingPrograms ty memodeb -everythingIO :: (ProgramGenerator pg, Typeable a) => + result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchPs withAbsents ty memodeb +everythingIO :: (ProgramGeneratorIO pg, Typeable a) => pg -- ^ program generator -> EveryIO a everythingIO = eIO undefined -eIO :: (ProgramGenerator pg, Typeable a) => +eIO :: (ProgramGeneratorIO pg, Typeable a) => a -- ^ dummy argument -> pg -- ^ program generator -> EveryIO a @@ -471,7 +566,7 @@ genExps filt rawGenProgs memodeb tht = case thTypeToType (extractTCL memodeb) tht of ty -> fmap (exprToTHExp (extractVL memodeb) . toCE) $ - filt memodeb ty $ fmap (toAnnExpr (reducer memodeb)) (rawGenProgs ty memodeb) + filt memodeb ty $ fmap (toAnnExpr (reducer $ extractCommon memodeb)) (rawGenProgs ty memodeb) -- Another advantage of these functions is that you do not need to define @instance Typeable@ for user defined types. -- ¤È»×¤Ã¤¿¤±¤É¡¤GHC¤Ç¤Ïderiving Typeable¤Ç´Êñ¤ËÄêµÁ¤Ç¤­¤ë¤·¡¤Typeable¤¬ÄêµÁ¤Ç¤­¤Ê¤¤·¿¤Ê¤ó¤Æ¤Ê¤µ¤½¤¦¡Êderiving Typeable¤·Ëº¤ì¤¿data type¤ò´Þ¤àdata¤¬¤½¤¦¡©¡Ë @@ -483,30 +578,44 @@ -} -- | @'findOne' pred@ finds an expression 'e' that satisfies @pred e == True@, and returns it in 'TH.Exp'. -findOne :: Typeable a => (a->Bool) -> TH.Exp -findOne pred = unsafePerformIO $ findDo (\e _ -> return e) pred +findOne :: Typeable a => + Bool -- ^ whether to include functions with unused arguments + -> (a->Bool) -> TH.Exp +findOne withAbsents pred = unsafePerformIO $ findDo (\e _ -> return e) withAbsents pred {- x Ç°¤Î¤¿¤á¤ä¤Ã¤Æ¤ß¤¿¤±¤É¡¤¤ä¤Ã¤Ñ¥À¥á¤ä¤Í¡¥¤Æ¤æ¡¼¤«¡¤Recomp¤Î¤Þ¤Þ¤ä¤Ã¤Æ³Æ¿¼¤µ¤Ç¸«¤ë¼ê¤Ï¤¢¤ë¤«¤â¡¥ findAny :: Typeable a => (a->Bool) -> [TH.Exp] findAny pred = unsafePerformIO $ findDo (\e r -> r >>= \es -> return (e:es)) pred -} -- | 'printOne' prints the expression found first. -printOne :: Typeable a => (a->Bool) -> IO TH.Exp -printOne pred = do expr <- findDo (\e _ -> return e) pred +printOne :: Typeable a => + Bool -- ^ whether to include functions with unused arguments + -> (a->Bool) -> IO TH.Exp +printOne withAbsents pred = do + expr <- findDo (\e _ -> return e) withAbsents pred putStrLn $ pprintUC expr return expr -- | 'printAll' prints all the expressions satisfying the given predicate. -printAll, printAny :: Typeable a => (a->Bool) -> IO () +printAll, printAny :: Typeable a => + Bool -- ^ whether to include functions with unused arguments + -> (a->Bool) -> IO () printAny = printAll -- provided just for backward compatibility printAll = findDo (\e r -> putStrLn (pprintUC e) >> r) -printAllF :: (Typeable a, Filtrable a) => (a->Bool) -> IO () -printAllF pred = do et <- getEverything +printAllF :: (Typeable a, Filtrable a) => + Bool -- ^ whether to include functions with unused arguments + -> (a->Bool) -> IO () +printAllF withAbsents pred = do + et <- getEverything withAbsents fet <- filterThenF pred et pprs fet -findDo :: Typeable a => (TH.Exp -> IO b -> IO b) -> (a->Bool) -> IO b -findDo op pred = do et <- getEverything +findDo :: Typeable a => + (TH.Exp -> IO b -> IO b) + -> Bool -- ^ whether to include functions with unused arguments + -> (a->Bool) -> IO b +findDo op withAbsents pred = do + et <- getEverything withAbsents md <- readIORef refmemodeb let mpto = timeout $ opt $ extractCommon md fp mpto (concat et) @@ -518,18 +627,24 @@ -- x ËÜÅö¤Ïrecomp¤Î¤Þ¤Þ¤Ç¤ä¤Ã¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥ -- | 'filterFirst' is like 'printAll', but by itself it does not print anything. Instead, it creates a stream of expressions represented in tuples of 'TH.Exp' and the expressions themselves. -filterFirst :: Typeable a => (a->Bool) -> IO (Every a) -filterFirst pred = do et <- getEverything +filterFirst :: Typeable a => + Bool -- ^ whether to include functions with unused arguments + -> (a->Bool) -> IO (Every a) +filterFirst withAbsents pred = do + et <- getEverything withAbsents filterThen pred et -- randomTestFilter should be applied after filterThen, because it's slower -filterFirstF :: (Typeable a, Filtrable a) => (a->Bool) -> IO (Every a) -filterFirstF pred = do et <- getEverything +filterFirstF :: (Typeable a, Filtrable a) => + Bool -- ^ whether to include functions with unused arguments + -> (a->Bool) -> IO (Every a) +filterFirstF withAbsents pred = do + et <- getEverything withAbsents filterThenF pred et filterThenF pred et = do fd <- filterThen pred et memodeb <- readIORef refmemodeb - let mpto = timeout $ opt $ extractCommon memodeb - return $ everyF mpto fd + let o = opt $ extractCommon memodeb + return $ everyF o fd {- refmemodeb ¤Ë¤¢¤ë¤â¤Î¤¬¼ÂºÝ¤Ë»È¤ï¤ì¤Æ¤¤¤ë¤â¤Î¤È¤Ï¸Â¤é¤Ê¤¤¡¥refmemodeb¤ò»È¤ï¤Ê¤¤¤È¤¤¤¦ÁªÂò¤â¤¢¤ë¤Î¤Ç¡¥ filterFirstF pred = do et <- getEverything filterThenF pred et @@ -543,9 +658,9 @@ getType ty memodeb = trToType (extractTCL memodeb) (typeOf ty) -} everyF :: (Typeable a, Filtrable a) => - Maybe Int -- ^ microsecs until timeout + Opt b -> Every a -> Every a -everyF mto = unMx . unsafeRandomTestFilter mto . Mx +everyF o = unMx . unsafeRandomTestFilter (timeout o) (fcnrand o) . Mx -- | 'filterThen' may be used to further filter the results. filterThen :: Typeable a => (a->Bool) -> Every a -> IO (Every a) @@ -553,12 +668,96 @@ let mpto = timeout $ opt $ extractCommon md return (map (fp mpto pred) ts) fp :: Typeable a => Maybe Int -> (a->Bool) -> [(Exp, a)] -> [(Exp, a)] +fp mpto pred = filter (\ (_,a) -> unsafePerformIO (maybeWithTO seq mpto (return (pred a))) == Just True) +{- fp _ pred [] = [] fp mpto pred (ea@(e,a):ts) = case unsafePerformIO (maybeWithTO seq mpto (return (pred a))) of Just True -> ea : fp mpto pred ts _ -> fp mpto pred ts +-} +-- fpartial :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> [(Exp, a)] +-- fpartial mpto pred tups = fp mpto pred $ map snd tups +-- The following tries the total version if the partial version fails. Not good when using the Partial class, because when using the Partial class the total and partial versions look the same. Now the Partial class is not used, so I recover this +fpartial :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> [(Exp, a)] +fpartial mpto pred ts = [ t | Just t <- map (fpart mpto pred) ts ] +fpart mpto pred (ea@(_,a),eap@(_,ap)) + = case unsafePerformIO (maybeWithTO seq mpto (return $! (pred ap))) of + Just True -> Just eap + Just False -> Nothing + Nothing -> case unsafePerformIO (maybeWithTO seq mpto (return $!(pred a))) of + Just True -> Just ea + _ -> Nothing +{- +fpartial _ pred [] = [] +fpartial mpto pred ((ea@(_,a),eap@(_,ap)):ts) + = case unsafePerformIO (maybeWithTO seq mpto (return (pred ap))) of + Just True -> eap : fpartial mpto pred ts + Just False -> fpartial mpto pred ts + Nothing -> case unsafePerformIO (maybeWithTO seq mpto (return (pred a))) of + Just True -> ea : fpartial mpto pred ts + _ -> fpartial mpto pred ts +-} +fpartialIO :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> IO [(Exp, a)] +fpartialIO mpto pred ts = do mbs <- interleaveActions {- parallelInterleaved -} $ map (fpartIO mpto pred) ts +--fpartialIO mpto pred ts = do mbs <- mapIO (fpartIO mpto pred) ts + return [ tup | Just tup <- mbs ] +#ifdef PAR +fpartialParIO :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> ParIO [(Exp, a)] +fpartialParIO mpto pred ts = do mbs <- mapParIO (liftIO . fpartIO mpto pred) ts + return [ tup | Just tup <- mbs ] +#endif +fpartIO :: Typeable a => Maybe Int -> (a->Bool) -> ((Exp, a),(Exp,a)) -> IO (Maybe (Exp, a)) +fpartIO mpto pred (ea@(_,a),eap@(_,ap)) + = do mbb <- maybeWithTO seq mpto $ return $! pred ap + case mbb of + Just True -> return $ Just eap + Just False -> return Nothing + Nothing -> do mbb2 <- maybeWithTO seq mpto $ return $! pred a + case mbb2 of + Just True -> return $ Just ea + _ -> return Nothing +{- ¤³¤ì¤À¤Èinterleave¤Ç¤­¤Ê¤¤¡¥ +fpartialIO _ pred [] = return [] +fpartialIO mpto pred ((ea@(_,a),eap@(_,ap)):ts) + = do mbb <- (maybeWithTO seq mpto (return $! pred ap)) + case mbb of + Just True -> fmap (eap :) $ fpartialIO mpto pred ts + Just False -> fpartialIO mpto pred ts + Nothing -> do mbb2 <- maybeWithTO seq mpto (return (pred a)) + case mbb2 of + Just True -> fmap (ea :) $ fpartialIO mpto pred ts + _ -> fpartialIO mpto pred ts +-} + +fpIO :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> IO [(Exp, a)] +fpIO mpto pred ts = do mbs <- {-interleaveActions -}sequence {- parallelInterleaved -} $ {- take 19 $ drop 6550 $ -} zipWith (fIO mpto pred) ts [0..] +--fpIO mpto pred ts = do mbs <- runParIO $ mapParIO (liftIO $ fIO mpto pred) $ zip ts [0..] + return [ tup | Just tup <- mbs ] +fIO :: Typeable a => Maybe Int -> (a->Bool) -> ((Exp, a),(Exp,a)) -> Int -> IO (Maybe (Exp, a)) +fIO mpto pred (ea@(e,a),eap@(_,ap)) i + = do hPutStrLn stderr (shows i " trying "++pprint e) + mbb <- maybeWithTO seq mpto $ return $! pred a + case mbb of + Just True -> return $ Just ea + _ -> return Nothing + + +mapIO :: (a -> IO b) -> [a] -> IO [b] +mapIO f xs = mapM (spawnIO . f) xs >>= mapM takeMVar +spawnIO :: IO a -> IO (MVar a) +spawnIO a = do + mv <- newEmptyMVar + forkIO (a >>= \v -> v `seq` putMVar mv v) + return mv + +#ifdef PAR +-- ¥Û¥ó¥È¤Ïspawn¤ò»È¤Ã¤¿¤Û¤¦¤¬Îɤµ¤½¤¦¤À¤¬¡¤NFDataÄêµÁ¤¹¤ë¤Î¤¬ÌÌÅݤʤΤǡ¥ +mapParIO :: (a -> ParIO b) -> [a] -> ParIO [b] +mapParIO f as = mapM (spawn_ . f) as >>= mapM get +#endif + -- | @io2pred@ converts a specification given as a set of I/O pairs to the predicate form which other functions accept. io2pred :: Eq b => [(a,b)] -> ((a->b)->Bool) io2pred ios f = all (\(a,b) -> f a == b) ios @@ -585,8 +784,9 @@ lengths = print . map length lengthsIO :: EveryIO a -> IO () lengthsIO eio = mapM_ (\d -> eio d >>= putStr . (' ':) . show . length) [0..] -lengthsIOn :: Int -> EveryIO a -> IO () +lengthsIOn, lengthsIOnLn :: Int -> EveryIO a -> IO () lengthsIOn depth eio = mapM_ (\d -> eio d >>= putStr . (' ':) . show . length) [0..depth-1] +lengthsIOnLn depth eio = lengthsIOn depth eio >> putStrLn "" printQ :: (Ppr a, Data a) => Q a -> IO () printQ q = runQ q >>= putStrLn . pprintUC diff --git a/MagicHaskeller/Analytical/FMExpr.hs b/MagicHaskeller/Analytical/FMExpr.hs --- a/MagicHaskeller/Analytical/FMExpr.hs +++ b/MagicHaskeller/Analytical/FMExpr.hs @@ -11,20 +11,20 @@ import MagicHaskeller.Analytical.Syntax -iopsToVisFME :: TBS -> [IOPair] -> FMExpr [IOPair] +iopsToVisFME :: TBS -> [IOPair a] -> FMExpr [IOPair a] iopsToVisFME tbs = iopsToFME . map (visIOP tbs) -iopsToFME :: [IOPair] -> FMExpr [IOPair] +iopsToFME :: [IOPair a] -> FMExpr [IOPair a] iopsToFME = assocsToFME . map iop2Assoc -visIOP :: TBS -> IOPair -> IOPair +visIOP :: TBS -> IOPair a -> IOPair a visIOP tbs iop = iop {inputs = visibles tbs $ inputs iop} -iop2Assoc :: IOPair -> (Expr, IOPair) +iop2Assoc :: IOPair a -> (Expr a, IOPair a) iop2Assoc iop = (output iop, iop) --- | @FMExpr a@ is a finite trie representing @Expr -> a@ +-- | @FMExpr a@ is a finite trie representing @Expr () -> a@ data FMExpr a = EmptyFME -- use of emptyFME in place of EmptyFME should not be as efficient, because there are many EmptyFME's. | FME { existentialFME :: IntMap.IntMap a, universalFME :: [a], conApFME :: IntMap.IntMap (FMExprs a) } deriving Show data FMExprs a = EmptyFMEs -- and there are many EmptyFMEs's, too. @@ -35,13 +35,13 @@ instance Functor FMExprs where fmap f EmptyFMEs = EmptyFMEs fmap f (FMEs {nilFMEs = n, consFMEs = c}) = FMEs {nilFMEs = f n, consFMEs = fmap (fmap f) c} -assocsToFME :: [(Expr, a)] -> FMExpr [a] +assocsToFME :: [(Expr b, a)] -> FMExpr [a] assocsToFME = foldr (\(k,v) -> updateFME (v:) [] k) emptyFME -updateFME :: (a->a) -> a -> Expr -> FMExpr a -> FMExpr a +updateFME :: (a->a) -> a -> Expr b -> FMExpr a -> FMExpr a updateFME f x t EmptyFME = updateFME f x t emptyFME -updateFME f x (E i) fme = fme { existentialFME = IntMap.insertWith (\_ -> f) i (f x) $ existentialFME fme } -updateFME f x (U i) fme = fme { universalFME = insertNth f x i $ universalFME fme } -updateFME f x (C _ (c Types.:::_) fs) fme = fme { conApFME = IntMap.insertWith (\_ -> updateFMEs f x fs) c (updateFMEs f x fs EmptyFMEs) $ conApFME fme } +updateFME f x (E _ i) fme = fme { existentialFME = IntMap.insertWith (\_ -> f) i (f x) $ existentialFME fme } +updateFME f x (U _ i) fme = fme { universalFME = insertNth f x i $ universalFME fme } +updateFME f x (C _ _ (c Types.:::_) fs) fme = fme { conApFME = IntMap.insertWith (\_ -> updateFMEs f x fs) (fromIntegral c) (updateFMEs f x fs EmptyFMEs) $ conApFME fme } updateFMEs f x es EmptyFMEs = updateFMEs f x es FMEs{nilFMEs = x, consFMEs = EmptyFME} updateFMEs f x [] fmes = fmes { nilFMEs = f $ nilFMEs fmes } updateFMEs f x (e:es) fmes = fmes { consFMEs = updateFME (updateFMEs f x es) EmptyFMEs e $ consFMEs fmes } @@ -55,37 +55,38 @@ -- returns the set of possible substitutions. Should the name be matchFME? -unifyFME :: Expr -> FMExpr a -> [(a,Subst)] +unifyFME :: Expr b -> FMExpr a -> [(a, Subst b)] unifyFME x fme = unifyFME' x fme emptySubst --unifyFME = matchFME -unifyFME' :: Expr -> FMExpr a -> Subst -> [(a,Subst)] +unifyFME' :: Expr b -> FMExpr a -> Subst b -> [(a, Subst b)] unifyFME' x EmptyFME s = [] -- unifyFME' (E i) fme s = error "cannot happen for now" -unifyFME' (E i) fme s = [ (x, s) | x <- valsFME fme ] -- ¤¿¤À¤·¡¤unifyFME (E _) fme¤Î¾ì¹ç¡ÊÁ´ÂΤ¬existential¤Î¾ì¹ç¡Ë¤Ï¤½¤â¤½¤âintroBK¤»¤º¤Ëundefined¤Ê°ú¿ô¤Ë¤·¤Æ¤·¤Þ¤¦¤Ù¤­¡¥¤É¤¦¤»¤½¤Î°ú¿ô¤Ï»È¤ï¤ì¤Ê¤¤¤Ã¤Æ¤³¤È¤À¤«¤é¡¥ +unifyFME' (E{}) fme s = [ (x, s) | x <- valsFME fme ] -- ¤¿¤À¤·¡¤unifyFME (E _) fme¤Î¾ì¹ç¡ÊÁ´ÂΤ¬existential¤Î¾ì¹ç¡Ë¤Ï¤½¤â¤½¤âintroBK¤»¤º¤Ëundefined¤Ê°ú¿ô¤Ë¤·¤Æ¤·¤Þ¤¦¤Ù¤­¡¥¤É¤¦¤»¤½¤Î°ú¿ô¤Ï»È¤ï¤ì¤Ê¤¤¤Ã¤Æ¤³¤È¤À¤«¤é¡¥ {- unifyFME' x@(E i) fme s o = case lookup i s of Nothing -> [ (x, [(i,e')] `plusSubst` s) | (e,x) <- assocsFME fme, let e' = fresh (o+) e ] -- assocsFME :: FMExpr a -> [(Expr,a)]¤À¤±¤É¡¤FMExpr¤Ë¾ðÊó¤ò»Ä¤·¤Æ¤ª¤±¤Ð̵Â̤ʷ׻»¤¬¤Ê¤¯¤Ê¤ë¤«¡¥¤Æ¤æ¡¼¤«¡¤Typed Constr¤ÎType¤ÎÉôʬ¤Î¤¿¤á¤Ë¤½¤¦¤¹¤ëɬÍפ¬¤¢¤ë¡¥ Just e -> unifyFME' e fme s o -} -unifyFME' x@(U i) fme s = [ (v, subst `plusSubst` s) +unifyFME' x@(U _ i) fme s = [ (v, subst `plusSubst` s) | (k,v) <- zip [0..] (universalFME fme) - , subst <- case lookup k s of Nothing -> [[(k,x)]] - Just (E j) -> [[(j,x)]] - Just (U j) | i==j -> [[]] - _ -> [] + , subst <- case lookup k s of Nothing -> [[(k,x)]] + Just (E{iD=j}) -> [[(j,x)]] + Just (U{iD=j}) | i==j -> [[]] + _ -> [] ] -unifyFME' x@(C _sz (c Types.::: _) xs) fme s = matchExistential ++ matchConstr +unifyFME' x@(C _ _sz (c Types.::: _) xs) fme s = matchExistential ++ matchConstr where matchExistential = [ (v, subst `plusSubst` s) | (k,v) <- zip [0..] (universalFME fme) , subst <- case lookup k s of Nothing -> [[(k,x)]] Just e -> unify e x ] - matchConstr = case IntMap.lookup c (conApFME fme) of Nothing -> [] + matchConstr = case IntMap.lookup (fromIntegral c) (conApFME fme) of + Nothing -> [] Just fmes -> unifyFMEs xs fmes s -unifyFMEs :: [Expr] -> FMExprs a -> Subst -> [(a,Subst)] +unifyFMEs :: [Expr b] -> FMExprs a -> Subst b -> [(a, Subst b)] unifyFMEs _ EmptyFMEs _ = [] unifyFMEs [] fmes s = [ (nilFMEs fmes, s) ] unifyFMEs (x:xs) fmes s = [ t | (fmes', s') <- unifyFME' x (consFMEs fmes) s, t <- unifyFMEs xs fmes' s' ] - +{- assocsFME :: FMExpr a -> [(Expr,a)] assocsFME EmptyFME = [] assocsFME fme = [ (E i, v) | (i,v) <- IntMap.toList (existentialFME fme) ] ++ [ (U i, v) | (i,v) <- zip [0..] (universalFME fme) ] @@ -93,6 +94,7 @@ assocsFMEs :: FMExprs a -> [([Expr],a)] assocsFMEs EmptyFMEs = [] assocsFMEs fmes = ([], nilFMEs fmes) : [ (x:xs, v) | (x,fmes') <- assocsFME (consFMEs fmes), (xs, v) <- assocsFMEs fmes ] +-} -- valsFME = map snd . assocsFME valsFME :: FMExpr a -> [a] @@ -104,16 +106,17 @@ valsFMEs fmes = nilFMEs fmes : [ v | fmes' <- valsFME (consFMEs fmes), v <- valsFMEs fmes' ] -- û¤¯¤·¤¿Êª¡¥¸úΨ¤Ï³Îǧ¤·¤Æ¤Ê¤¤¡¥ -matchFME :: Expr -> FMExpr a -> [(a,Subst)] +matchFME :: Expr b -> FMExpr a -> [(a, Subst b)] matchFME x fme = matchFME' x fme emptySubst -matchFME' :: Expr -> FMExpr a -> Subst -> [(a,Subst)] +matchFME' :: Expr b -> FMExpr a -> Subst b -> [(a, Subst b)] matchFME' x EmptyFME s = [] -matchFME' (E i) fme s = [ (x, s) | x <- valsFME fme ] -- ¤¿¤À¤·¡¤matchFME (E _) fme¤Î¾ì¹ç¡ÊÁ´ÂΤ¬existential¤Î¾ì¹ç¡Ë¤Ï¤½¤â¤½¤âintroBK¤»¤º¤Ëundefined¤Ê°ú¿ô¤Ë¤·¤Æ¤·¤Þ¤¦¤Ù¤­¡¥¤É¤¦¤»¤½¤Î°ú¿ô¤Ï»È¤ï¤ì¤Ê¤¤¤Ã¤Æ¤³¤È¤À¤«¤é¡¥ +matchFME' (E {}) fme s = [ (x, s) | x <- valsFME fme ] -- ¤¿¤À¤·¡¤matchFME (E _) fme¤Î¾ì¹ç¡ÊÁ´ÂΤ¬existential¤Î¾ì¹ç¡Ë¤Ï¤½¤â¤½¤âintroBK¤»¤º¤Ëundefined¤Ê°ú¿ô¤Ë¤·¤Æ¤·¤Þ¤¦¤Ù¤­¡¥¤É¤¦¤»¤½¤Î°ú¿ô¤Ï»È¤ï¤ì¤Ê¤¤¤Ã¤Æ¤³¤È¤À¤«¤é¡¥ -- Universal variables only match to existentials -matchFME' x@(U _) fme s = matchExistential x fme s +matchFME' x@(U{}) fme s = matchExistential x fme s -- Constractor applications can match to both existentials and constructor applications with the same constructor. -matchFME' x@(C _sz (c Types.::: _) xs) fme s = matchExistential x fme s ++ matchConstr - where matchConstr = case IntMap.lookup c (conApFME fme) of Nothing -> [] +matchFME' x@(C _ _sz (c Types.::: _) xs) fme s = matchExistential x fme s ++ matchConstr + where matchConstr = case IntMap.lookup (fromIntegral c) (conApFME fme) of + Nothing -> [] Just fmes -> matchFMEs xs fmes s matchExistential x fme s = [ (v, subst `plusSubst` s) | (k,v) <- zip [0..] (universalFME fme) @@ -121,7 +124,7 @@ Just e -> unify e x ] -- matchFMEs matches corresponding constructor fields -matchFMEs :: [Expr] -> FMExprs a -> Subst -> [(a,Subst)] +matchFMEs :: [Expr b] -> FMExprs a -> Subst b -> [(a, Subst b)] matchFMEs _ EmptyFMEs _ = [] matchFMEs [] fmes s = [ (nilFMEs fmes, s) ] matchFMEs (x:xs) fmes s = [ t | (fmes', s') <- matchFME' x (consFMEs fmes) s, t <- matchFMEs xs fmes' s' ] diff --git a/MagicHaskeller/Analytical/Parser.hs b/MagicHaskeller/Analytical/Parser.hs --- a/MagicHaskeller/Analytical/Parser.hs +++ b/MagicHaskeller/Analytical/Parser.hs @@ -3,7 +3,7 @@ -- module MagicHaskeller.Analytical.Parser where -import Data.List(sort, group) +import Data.List(sort, group, genericLength) import Control.Monad -- hiding (guard) import Control.Monad.State -- hiding (guard) import Data.Char(ord) @@ -12,8 +12,8 @@ import qualified Data.IntMap as IntMap import Language.Haskell.TH hiding (match) -import MagicHaskeller.CoreLang(VarLib) -import qualified MagicHaskeller.Types as Types +import MagicHaskeller.CoreLang(VarLib, Var) +import qualified MagicHaskeller.Types as T import MagicHaskeller.PriorSubsts hiding (unify) import MagicHaskeller.TyConLib import MagicHaskeller.ReadTHType(thTypeToType) @@ -21,8 +21,9 @@ import MagicHaskeller.Analytical.Syntax +import Data.Word -data XVarLib = XVL {varLib :: VarLib, invVarLib :: Map.Map String Int, zeroID :: Int, succID :: Int, negateID :: Int} deriving Show +data XVarLib = XVL {varLib :: VarLib, invVarLib :: Map.Map String Var, zeroID :: Var, succID :: Var, negateID :: Var} deriving Show -- We compare nameBase ignoring the module name, instead of using equivalence over Name's. mkXVarLib :: VarLib -> XVarLib @@ -37,28 +38,28 @@ extractName (ConE name) = [name] extractName (VarE name) = [name] extractName _ = [] -parseTypedIOPairss :: (Functor m, MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, Types.Typed [IOPair])] +parseTypedIOPairss :: (Functor m, MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])] parseTypedIOPairss tcl xvl ds = inferTypedIOPairss =<< parseTypedIOPairss' tcl xvl ds -inferTypedIOPairss :: MonadPlus m => [(Name,(Maybe Types.Type, Maybe (Types.Typed [IOPair])))] -> PriorSubsts m [(Name, Types.Typed [IOPair])] -inferTypedIOPairss ((name, (Just ty, Just (iops Types.::: infty))):ts) +inferTypedIOPairss :: MonadPlus m => [(Name,(Maybe T.Type, Maybe (T.Typed [IOPair T.Type])))] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])] +inferTypedIOPairss ((name, (Just ty, Just (iops T.::: infty))):ts) = do apinfty <- applyPS infty - mguPS apinfty $ Types.quantify ty + mguPS apinfty $ T.quantify ty -- updateSubstPS (return . unquantifySubst) s <- getSubst - let hd = (name, map (tapplyIOP s) iops Types.:::ty) + let hd = (name, map (tapplyIOP s) iops T.:::ty) tl <- inferTypedIOPairss ts return (hd:tl) -inferTypedIOPairss ((name, (Nothing, Just (iops Types.::: infty))):ts) +inferTypedIOPairss ((name, (Nothing, Just (iops T.::: infty))):ts) = do s <- getSubst - let hd = (name, map (tapplyIOP $ quantifySubst s) iops Types.::: Types.apply s infty) + let hd = (name, map (tapplyIOP s) iops T.::: T.apply s infty) tl <- inferTypedIOPairss ts return (hd:tl) inferTypedIOPairss ((_nam, (Just _t, Nothing)):ts) = inferTypedIOPairss ts -- pattern including only a type signature. This is still useful when incorporating with MagicHaskeller, but MagH has its own parser, so let's ignore the pattern silently. inferTypedIOPairss ((_, (Nothing, Nothing)):_) = error "MagicHaskeller.TypedIOPairs.inferTypedIOPairss: impossible" inferTypedIOPairss [] = return [] -parseTypedIOPairss' :: (Functor m,MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, (Maybe Types.Type, Maybe (Types.Typed [IOPair])))] +parseTypedIOPairss' :: (Functor m,MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, (Maybe T.Type, Maybe (T.Typed [IOPair T.Type])))] parseTypedIOPairss' tcl xvl ds = do tups <- parseIOPairss xvl ds return $ Map.toList $ Map.fromListWith plus @@ -66,22 +67,22 @@ [(name, (Nothing, Just tiops)) | (name, tiops) <- tups]) (a,b) `plus` (c,d) = (a `mplus` c, b `mplus` d) -parseTypes :: TyConLib -> [Dec] -> [(Name,Types.Type)] +parseTypes :: TyConLib -> [Dec] -> [(Name,T.Type)] parseTypes tcl ds = [ (name, thTypeToType tcl ty) | SigD name ty <- ds ] -parseIOPairss :: (Functor m, MonadPlus m) => XVarLib -> [Dec] -> PriorSubsts m [(Name, Types.Typed [IOPair])] +parseIOPairss :: (Functor m, MonadPlus m) => XVarLib -> [Dec] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])] parseIOPairss xvl (FunD funname clauses : decs) = do tiops <- mapM (clauseToIOPair xvl) clauses let (iops,t:ts) = unzipTyped tiops ty <- foldM mgtPS t ts s <- getSubst - let hd = (funname, map (tapplyIOP s) iops Types.::: ty) + let hd = (funname, map (tapplyIOP s) iops T.::: ty) tl <- parseIOPairss xvl decs return $ hd:tl parseIOPairss xvl (ValD (VarP name) (NormalB ex) [] : decs) - = do (vout Types.::: tout, _intmap) <- runStateT (inferType (thExpToExpr xvl ex)) IntMap.empty - let hd = (name, [IOP 0 [] vout] Types.::: tout) + = do (vout, _intmap) <- runStateT (inferType (thExpToExpr xvl ex)) IntMap.empty + let hd = (name, [IOP 0 [] vout] T.::: ann vout) tl <- parseIOPairss xvl decs return $ hd:tl parseIOPairss xvl (_:decs) = parseIOPairss xvl decs @@ -89,64 +90,62 @@ -- ·¿Àë¸À¤¬¤¢¤ë¾ì¹ç¡¤¤½¤Îforall¤Ê¤ä¤Ä¤Ë¥Þ¥Ã¥Á¤·¤Æ½ªÎ»¡¥ -- ¤Ê¤¤¾ì¹ç¡¤¤½¤Î¤Þ¤Þ´Ø¿ô¤Ë¤·¤Æ½ªÎ»¡¥ -clauseToIOPair :: (Functor m, MonadPlus m) => XVarLib -> Clause -> PriorSubsts m (Types.Typed IOPair) +clauseToIOPair :: (Functor m, MonadPlus m) => XVarLib -> Clause -> PriorSubsts m (T.Typed (IOPair T.Type)) clauseToIOPair ivl cl = fmap fst $ runStateT (clauseToIOPair' ivl cl) IntMap.empty clauseToIOPair' ivl (Clause inpats (NormalB ex) []) =do ins <- mapM inferT (reverse $ map (patToExp ivl) inpats) - let (vins,tins) = unzipTyped ins - vout Types.::: tout <- inferT (thExpToExpr ivl ex) - ty <- lift $ applyPS (Types.popArgs tins tout) - return $ normalizeMkIOP vins vout Types.::: ty + vout <- inferT (thExpToExpr ivl ex) + ty <- lift $ applyPS (T.popArgs (map ann ins) $ ann vout) + return $ normalizeMkIOP ins vout T.::: ty clauseToIOPair' _ _ = error "Neither _guards_ nor _where_clauses_ are permitted in clauses representing I/O pairs." -- In future where-clauses might be supported. -matchType :: MonadPlus m => [Types.Type] -> Types.Type -> Types.Type -> PriorSubsts m () -matchType argtys retty ty = mguType argtys retty (Types.quantify ty) >> updateSubstPS (return . unquantifySubst) -unquantifySubst = map (\(v,t) -> (v, Types.unquantify t)) -quantifySubst = map (\(v,t) -> (v, Types.quantify t)) -mguType (t:ts) r (u Types.:->v) = do mguPS t u - s <- getSubst - mguType (map (Types.apply s) ts) (Types.apply s r) v -mguType [] r v = Types.mgu r v +matchType :: MonadPlus m => [T.Type] -> T.Type -> T.Type -> PriorSubsts m () +matchType argtys retty ty = mguType argtys retty (T.quantify ty) >> updateSubstPS (return . unquantifySubst) +unquantifySubst = map (\(v,t) -> (v, T.unquantify t)) +mguType (t:ts) r (u T.:->v) = do mguPS t u + s <- getSubst + mguType (map (T.apply s) ts) (T.apply s r) v +mguType [] r v = T.mgu r v mguType (_:_) _ _ = error "Not enough arguments supplied." -inferType, inferT :: MonadPlus m => Expr -> StateT (IntMap.IntMap Types.Type) (PriorSubsts m) (Types.Typed Expr) -inferType e = do e' Types.:::t <- inferT e +inferType, inferT :: MonadPlus m => Expr a -> StateT (IntMap.IntMap T.Type) (PriorSubsts m) (Expr T.Type) +inferType e = do e' <- inferT e s <- lift getSubst - return (tapplyExpr s e' Types.::: Types.apply s t) -inferT v@(U i) = do tenv <- get + return $ tapplyExpr s e' +inferT v@(U _ i) = do + tenv <- get case IntMap.lookup i tenv of Nothing -> do tvid <- lift newTVar - let ty = Types.TV tvid + let ty = T.TV tvid put $ IntMap.insert i ty tenv - return (v Types.::: ty) + return (U ty i) Just ty -> do apty <- lift $ applyPS ty - return (v Types.::: apty) -inferT (C sz (i Types.:::ty) es) + return (U apty i) +inferT (C _ sz (i T.:::ty) es) = do es' <- mapM inferT es - lift $ do let (typees, typers) = unzipTyped es' - let tvs = map head $ group $ sort $ Types.tyvars ty - tvid <- reserveTVars $ length tvs - let apty = Types.apply (zip tvs $ map Types.TV [tvid..]) ty - rty <- foldM funApM apty typers + lift $ do let tvs = map head $ group $ sort $ T.tyvars ty + tvid <- reserveTVars $ genericLength tvs + let apty = T.apply (zip tvs $ map T.TV [tvid..]) ty + rty <- foldM funApM apty $ map ann es' rapty <- applyPS rty - return $ C sz (i Types.:::apty) typees Types.::: rapty -funApM :: MonadPlus m => Types.Type -> Types.Type -> PriorSubsts m Types.Type -funApM (a Types.:-> r) t = fAM a r t -funApM (a Types.:> r) t = fAM a r t -funApM (Types.TV i) t = do tvid <- newTVar - updatePS [(i,t Types.:->Types.TV tvid)] - return $ Types.TV tvid + return $ C rapty sz (i T.:::apty) es' +funApM :: MonadPlus m => T.Type -> T.Type -> PriorSubsts m T.Type +funApM (a T.:-> r) t = fAM a r t +funApM (a T.:> r) t = fAM a r t +funApM (T.TV i) t = do tvid <- newTVar + updatePS [(i,t T.:->T.TV tvid)] + return $ T.TV tvid funApM _ _ = fail "too many arguments applied." fAM apa r t = do apt <- applyPS t mguPS apa apt applyPS r -tapplyIOP :: Types.Subst -> IOPair -> IOPair +tapplyIOP :: T.Subst -> IOPair T.Type -> IOPair T.Type tapplyIOP s (IOP bvs ins out) = IOP bvs (map (tapplyExpr s) ins) (tapplyExpr s out) -tapplyExpr :: Types.Subst -> Expr -> Expr -tapplyExpr sub (C sz (i Types.:::ty) es) = C sz (i Types.:::Types.apply sub ty) (map (tapplyExpr sub) es) +tapplyExpr :: T.Subst -> Expr T.Type -> Expr T.Type +tapplyExpr sub (C t sz (i T.:::cty) es) = C (T.apply sub t) sz (i T.:::T.apply sub cty) (map (tapplyExpr sub) es) tapplyExpr _ v = v {- substitution¤ò°ìÅÙget¤·¤¿¤é¡¤¤½¤ì¤òÁ´ÂΤËÇȵڤµ¤»¤ëɬÍפ¬¤¢¤ë¡© @@ -156,31 +155,30 @@ -- MagicHaskeller.Types¤ËÃÖ¤¯¤Ù¤­¤È¤¤¤¦µ¤¤¬¤·¤Ê¤¤¤Ç¤â¤Ê¤¤¡¥ unzipTyped [] = ([],[]) -unzipTyped ((e Types.:::t):ets) = let (es,ts) = unzipTyped ets in (e:es,t:ts) +unzipTyped ((e T.:::t):ets) = let (es,ts) = unzipTyped ets in (e:es,t:ts) -getMbTypedConstr :: XVarLib -> Name -> Maybe (Types.Typed Constr) +getMbTypedConstr :: XVarLib -> Name -> Maybe (T.Typed Constr) getMbTypedConstr xvl name = fmap (mkTypedConstr xvl) $ Map.lookup (nameBase name) (invVarLib xvl) -getTypedConstr :: XVarLib -> Name -> Types.Typed Constr +getTypedConstr :: XVarLib -> Name -> T.Typed Constr getTypedConstr xvl name = case Map.lookup (nameBase name) $ invVarLib xvl of Just c -> mkTypedConstr xvl c Nothing -> error ("could not find "++show name) -mkTypedConstr xvl c = c Types.::: PD.dynType (varLib xvl!c) -litToExp ivl (IntegerL i) | i>=0 = natToConExp ivl i - | otherwise = cap (mkTypedConstr ivl (negateID ivl)) [natToConExp ivl (-i)] --- litToExp tcl (CharL c) = C (Ctor (ord c) (c¤ËÁêÅö¤¹¤ëÅÛ. ¤¢¤ëÌõ¤Ê¤¤?)) [] ¤Æ¤æ¡¼¤«¡¤constructor°·¤¤¤Ë¤¹¤ì¤Ð¤¤¤¤¤Î¤À¤¬¡¥ --- litToExp tcl (StringL str) = strToConExp tcl str -patToExp ivl (LitP l) = litToExp ivl l -patToExp ivl (VarP name) = U (strToInt $ nameBase name) -patToExp ivl (TupP pats) = cap (getTypedConstr ivl (tupleDataName (length pats))) (map (patToExp ivl) pats) -patToExp ivl (ConP name pats) = cap (getTypedConstr ivl name) (map (patToExp ivl) pats) -patToExp ivl (InfixP p1 name p2) = cap (getTypedConstr ivl name) (map (patToExp ivl) [p1,p2]) +mkTypedConstr xvl c = c T.::: PD.dynType (varLib xvl!c) +patToExp ivl (LitP (IntegerL i)) | i>=0 = natToConExp ivl i + | otherwise = cap () (mkTypedConstr ivl (negateID ivl)) [natToConExp ivl (-i)] +-- patToExp tcl (LitP (CharL c)) = C (Ctor (ord c) (c¤ËÁêÅö¤¹¤ëÅÛ. ¤¢¤ëÌõ¤Ê¤¤?)) [] +-- patToExp tcl (LitP (StringL str)) = strToConExp tcl str +patToExp ivl (VarP name) = U () (strToInt $ nameBase name) +patToExp ivl (TupP pats) = cap () (getTypedConstr ivl (tupleDataName (length pats))) (map (patToExp ivl) pats) +patToExp ivl (ConP name pats) = cap () (getTypedConstr ivl name) (map (patToExp ivl) pats) +patToExp ivl (InfixP p1 name p2) = cap () (getTypedConstr ivl name) (map (patToExp ivl) [p1,p2]) patToExp ivl (TildeP p) = patToExp ivl p patToExp ivl (AsP _ _) = error "As (@) patterns not supported." -patToExp ivl WildP = U (strToInt "_") -- will not work correctly if there are more than one wildcards in one I/O pair, I think. +patToExp ivl WildP = U () (strToInt "_") -- will not work correctly if there are more than one wildcards in one I/O pair, I think. patToExp ivl (RecP _ _) = error "Record patterns not supported." patToExp ivl (ListP pats) = foldr cons nil $ map (patToExp ivl) pats - where nil = C 1 (getTypedConstr ivl '[]) [] - cons e1 e2 = cap (getTypedConstr ivl '(:)) [e1,e2] + where nil = C () 1 (getTypedConstr ivl '[]) [] + cons e1 e2 = cap () (getTypedConstr ivl '(:)) [e1,e2] patToExp ivl (SigP pat _t) = patToExp ivl pat -- Or should this cause an error? -- Is this encoding really quicker than raw String (or maybe PackedString)? @@ -190,23 +188,25 @@ natLimit = 32 natToConExp ivl i -- x | i > natLimit = C (Ctor i (i¤ËÁêÅö¤¹¤ëÅÛ. ¤¢¤ëÌõ¤Ê¤¤?)) [] | otherwise = smallNat ivl i -smallNat ivl 0 = C 1 (mkTypedConstr ivl (zeroID ivl)) [] -smallNat ivl i = cap (mkTypedConstr ivl (succID ivl)) [smallNat ivl (i-1)] +smallNat ivl 0 = C () 1 (mkTypedConstr ivl (zeroID ivl)) [] +smallNat ivl i = cap () (mkTypedConstr ivl (succID ivl)) [smallNat ivl (i-1)] -- strToConExp tcl "" = C (Ctor 0 ([]¤ËÁêÅö¤¹¤ëÅÛ)) [] -thExpToExpr ivl (VarE name) = case getMbTypedConstr ivl name of Nothing -> U (strToInt $ nameBase name) - Just x -> C 1 x [] -thExpToExpr ivl (ConE name) = C 1 (getTypedConstr ivl name) [] -thExpToExpr ivl (LitE l) = litToExp ivl l -thExpToExpr ivl (AppE f x) = case thExpToExpr ivl f of C sz c xs -> let thx = thExpToExpr ivl x - in C (sz + size thx) c (xs ++ [thx]) -- O(n^2) - U _ -> error "Only constructor applications are permitted in IO examples." -thExpToExpr ivl (InfixE (Just x) (ConE name) (Just y)) = cap (getTypedConstr ivl name) [thExpToExpr ivl x, thExpToExpr ivl y] -thExpToExpr ivl (InfixE (Just x) (VarE name) (Just y)) = cap (getTypedConstr ivl name) [thExpToExpr ivl x, thExpToExpr ivl y] -thExpToExpr ivl (TupE es) = cap (getTypedConstr ivl (tupleDataName (length es))) (map (thExpToExpr ivl) es) +thExpToExpr :: XVarLib -> Exp -> Expr () +thExpToExpr ivl (VarE name) = case getMbTypedConstr ivl name of Nothing -> U () (strToInt $ nameBase name) + Just x -> C () 1 x [] +thExpToExpr ivl (ConE name) = C () 1 (getTypedConstr ivl name) [] +thExpToExpr ivl (LitE (IntegerL i)) | i >= 0 = natToConExp ivl i + | otherwise = cap () (mkTypedConstr ivl (negateID ivl)) [natToConExp ivl (-i)] +thExpToExpr ivl (AppE f x) = case thExpToExpr ivl f of C () sz c xs -> let thx = thExpToExpr ivl x + in C () (sz + size thx) c (xs ++ [thx]) -- O(n^2) + U () _ -> error "Only constructor applications are permitted in IO examples." +thExpToExpr ivl (InfixE (Just x) (ConE name) (Just y)) = cap () (getTypedConstr ivl name) [thExpToExpr ivl x, thExpToExpr ivl y] +thExpToExpr ivl (InfixE (Just x) (VarE name) (Just y)) = cap () (getTypedConstr ivl name) [thExpToExpr ivl x, thExpToExpr ivl y] +thExpToExpr ivl (TupE es) = cap () (getTypedConstr ivl (tupleDataName (length es))) (map (thExpToExpr ivl) es) thExpToExpr ivl (ListE es) = foldr cons nil $ map (thExpToExpr ivl) es - where nil = cap (getTypedConstr ivl '[]) [] - cons e1 e2 = cap (getTypedConstr ivl '(:)) [e1,e2] + where nil = cap () (getTypedConstr ivl '[]) [] + cons e1 e2 = cap () (getTypedConstr ivl '(:)) [e1,e2] thExpToExpr ivl (SigE e _t) = thExpToExpr ivl e thExpToExpr _ _ = error "Unsupported expression in IO examples." {- diff --git a/MagicHaskeller/Analytical/Syntax.hs b/MagicHaskeller/Analytical/Syntax.hs --- a/MagicHaskeller/Analytical/Syntax.hs +++ b/MagicHaskeller/Analytical/Syntax.hs @@ -6,40 +6,57 @@ import Control.Monad -- hiding (guard) import Data.List(nub) -import qualified MagicHaskeller.Types as Types +import qualified MagicHaskeller.Types as T +import Data.Word + +import MagicHaskeller.CoreLang(Var) + -- -- Datatypes -- -data IOPair = IOP { numUniIDs :: Int -- ^ number of variables quantified with forall - , inputs :: [Expr] -- ^ input example for each argument. The last argument comes first. - , output :: Expr} +data IOPair a = IOP { numUniIDs :: Int -- ^ number of variables quantified with forall + , inputs :: [Expr a] -- ^ input example for each argument. The last argument comes first. + , output :: Expr a} deriving (Show,Eq) +instance Functor IOPair where + fmap f iop = iop{inputs = map (fmap f) $ inputs iop, output = fmap f $ output iop} type TBS = [Bool] -- ^ the to-be-sought list -data Expr = E Int -- ^ existential variable. When doing analytical synthesis, there is no functional variable. - | U Int -- ^ universal variable. When doing analytical synthesis, there is no functional variable. +data Expr a = E {ann :: a, iD :: Int} -- ^ existential variable. When doing analytical synthesis, there is no functional variable. + | U {ann :: a, iD :: Int} -- ^ universal variable. When doing analytical synthesis, there is no functional variable. -- Int¤Ç¤Ï¤Ê¤¯TH.Name¤òľÀܻȤä¿Êý¤¬¤è¤¤¡© - | C {sz :: Int, ctor :: Types.Typed Constr, fields :: [Expr]} - deriving (Eq, Show) -type Constr = Int -normalizeMkIOP :: [Expr] -> Expr -> IOPair + | C {ann :: a, sz :: Int, ctor :: T.Typed Constr, fields :: [Expr a]} + deriving (Show) +instance Eq (Expr a) where -- We just ignore the annotations and compare syntactically. + E{iD=i} == E{iD=j} = i==j + U{iD=i} == U{iD=j} = i==j + C{ctor=c,fields=fs} == C{ctor=d,fields=gs} = T.typee c == T.typee d && fs == gs + -- We do not chech the equivalence of sizes because that would force evaluation. + _ == _ = False +instance Functor Expr where + fmap f (E a i) = E (f a) i + fmap f (U a i) = U (f a) i + fmap f c = c{ann = f (ann c), fields = map (fmap f) $ fields c} + +type Constr = Var +normalizeMkIOP :: [Expr a] -> Expr a -> IOPair a normalizeMkIOP ins out = let varIDs = nub $ concatMap vr (out : ins) tup = zip varIDs [0..] in mapIOP (mapU (\tv -> case lookup tv tup of Just n -> n)) IOP{numUniIDs = length varIDs, inputs = ins, output = out} -vr (U i) = [i] -vr (C _ _ es) = concatMap vr es -mapU f (U i) = U $ f i -mapU f (C sz c xs) = C sz c $ map (mapU f) xs +vr (U _ i) = [i] +vr (C{fields=es}) = concatMap vr es +mapU f (U a i) = U a $ f i +mapU f e@(C{fields=xs}) = e{fields=map (mapU f) xs} -maybeCtor :: Expr -> Maybe (Types.Typed Constr) -maybeCtor (C _ c _) = Just c -maybeCtor _ = Nothing +maybeCtor :: Expr a -> Maybe (T.Typed Constr) +maybeCtor (C{ctor=c}) = Just c +maybeCtor _ = Nothing -hasExistential (E _) = True -hasExistential (U _) = False -hasExistential (C _ _ es) = any hasExistential es +hasExistential (E{}) = True +hasExistential (U{}) = False +hasExistential (C{fields=es}) = any hasExistential es visibles tbs ins = [ i | (True,i) <- zip tbs ins ] @@ -47,14 +64,14 @@ -- unification -- -type Subst = [(Int,Expr)] +type Subst a = [(Int, Expr a)] -unify (C _ i xs) (C _ j ys) | Types.typee i == Types.typee j = unifyList xs ys - | otherwise = mzero -unify e f | e==f = return [] -unify (E i) e = bind i e -unify e (E i) = bind i e +unify (C _ _ i xs) (C _ _ j ys) | T.typee i == T.typee j = unifyList xs ys + | otherwise = mzero +unify e f | e==f = return [] +unify (E _ i) e = bind i e +unify e (E _ i) = bind i e unify _ _ = mzero unifyList [] [] = return [] @@ -67,38 +84,38 @@ | otherwise = return [(i,e)] -- | 'apply' applies a substitution which replaces existential variables to an expression. -apply subst v@(E i) = maybe v id $ lookup i subst -apply subst v@(U _) = v -apply subst (C _ i xs) = cap i (map (apply subst) xs) -- ÃÙ¤¤¤«¤Í +apply subst v@(E _ i) = maybe v id $ lookup i subst +apply subst v@(U _ _) = v +apply subst (C a _ i xs) = cap a i (map (apply subst) xs) -- ÃÙ¤¤¤«¤Í -i `occursIn` (E j) = i==j -i `occursIn` (U _) = False -i `occursIn` (C _ _ xs) = any (i `occursIn`) xs +i `occursIn` (E _ j) = i==j +i `occursIn` (U _ _) = False +i `occursIn` (C _ _ _ xs) = any (i `occursIn`) xs -plusSubst :: Subst -> Subst -> Subst +plusSubst :: Subst a -> Subst a -> Subst a s0 `plusSubst` s1 = [(u, apply s0 t) | (u,t) <- s1] ++ s0 emptySubst = [] -fresh f e@(E _) = e -fresh f (U i) = E $ f i -fresh f (C s c xs) = C s c (map (fresh f) xs) +fresh f e@(E{}) = e +fresh f (U a i) = E a $ f i +fresh f (C a s c xs) = C a s c (map (fresh f) xs) -- | fusion of @apply s@ and @fresh f@ -apfresh s e@(E _) = e -- NB: this RHS is incorrect if apfresh is used for UniT (because s may include a replacement of e). -apfresh s (U i) = maybe (E i) id $ lookup i s -apfresh s (C _sz c xs) = cap c (map (apfresh s) xs) -mapE f e@(U _) = e -mapE f (E i) = E $ f i -mapE f (C s c xs) = C s c (map (mapE f) xs) +apfresh s e@(E{}) = e -- NB: this RHS is incorrect if apfresh is used for UniT (because s may include a replacement of e). +apfresh s (U a i) = maybe (E a i) id $ lookup i s +apfresh s (C a _sz c xs) = cap a c (map (apfresh s) xs) +mapE f e@(U{}) = e +mapE f (E a i) = E a $ f i +mapE f e@(C{fields=xs}) = e{fields=map (mapE f) xs} -- Note that numUniIDs will not be touched. applyIOPs s iops = map (applyIOP s) iops applyIOP s iop = mapIOP (apply s) iop mapIOP f (IOP bvs ins out) = IOP bvs (map f ins) (f out) -mapTypee f (x Types.::: t) = f x Types.::: t +mapTypee f (x T.::: t) = f x T.::: t -- @@ -109,18 +126,18 @@ initTS :: TermStat initTS = TS $ replicate (length termCrit) True -updateTS :: [Expr] -> [Expr] -> TermStat -> TermStat +updateTS :: [Expr a] -> [Expr a] -> TermStat -> TermStat updateTS bkis is (TS bs) = TS $ zipWith (&&) bs [ bkis < is | (<) <- termCrit ] evalTS :: TermStat -> Bool evalTS (TS bs) = or bs -- termination criteria. Enumerate anything that come to your mind. (Should this be an option?) -termCrit :: [[Expr]->[Expr]->Bool] +termCrit :: [[Expr a]->[Expr a]->Bool] -- termCrit = [fullyLex, aWise, revFullyLex, revAWise ] -- , linear --termCrit = [aWise,revAWise] termCrit = [aWise] -fullyLex, revFullyLex, aWise, revAWise, linear :: [Expr]->[Expr]->Bool +fullyLex, revFullyLex, aWise, revAWise, linear :: [Expr a]->[Expr a]->Bool fullyLex = lessRevListsLex cmpExprs revFullyLex= lessListsLex cmpExprs aWise = lessRevListsLex cmpExprSzs @@ -130,7 +147,7 @@ -- ¤Ç¤â¡¤case¤Ç¤Ö¤Ã¤¿Àڤ俤¢¤È¤Î¤¹¤Ù¤Æ¤Î°ú¿ô¤òÈæ³Ó¤·¤Æ¤¤¤ë¤«¤éÃÙ¤¤¤Î¤Ç¤¢¤Ã¤Æ¡¤°ìÈֺǽé¤ÎÃʳ¬¤Î°ú¿ô¤À¤±¤ÇÈæ³Ó¤¹¤ì¤Ð®¤¤¤Î¤Ç¤Ï¡© -- ¤Ç¤â¡¤Ackermann's function¤Ç¹Í¤¨¤ë¤È¡¤¤ä¤Ã¤Ñ¤½¤ì¤Ç¤Ï¥À¥á¤Ã¤Ý¤¤¡¥ -revArgs :: ([Expr]->[Expr]->Bool) -> [Expr]->[Expr]->Bool +revArgs :: ([Expr a]->[Expr a]->Bool) -> [Expr a]->[Expr a]->Bool revArgs cmp ls rs = cmp (reverse ls) (reverse rs) lessRevListsLex cmp = revArgs (lessListsLex cmp) @@ -143,15 +160,15 @@ cmpExprss _ [] = GT cmpExprss (e0:es0) (e1:es1) = case cmpExprs e0 e1 of EQ -> cmpExprss es0 es1 c -> c -cmpExprs (C _ _ fs) (C _ _ gs) = cmpExprss fs gs -cmpExprs _ (C _ _ _) = LT -cmpExprs (C _ _ _) _ = GT -cmpExprs _ _ = EQ +cmpExprs (C _ _ _ fs) (C _ _ _ gs) = cmpExprss fs gs +cmpExprs _ (C _ _ _ _) = LT +cmpExprs (C _ _ _ _) _ = GT +cmpExprs _ _ = EQ cmpExprSzs e0 e1 = compare (size e0) (size e1) -size (C sz _ fs) = sz +size (C _ sz _ fs) = sz size _ = 1 -- questionable? -cap con fs = C (1 + sum (map size fs)) con fs +cap a con fs = C a (1 + sum (map size fs)) con fs -- Q: Are existential variables always smaller than constructor applications? A: No, I'm afraid. -- If we want to make sure the termination, we can always return GT when questionable; diff --git a/MagicHaskeller/Analytical/Synthesize.hs b/MagicHaskeller/Analytical/Synthesize.hs --- a/MagicHaskeller/Analytical/Synthesize.hs +++ b/MagicHaskeller/Analytical/Synthesize.hs @@ -4,7 +4,7 @@ {-# LANGUAGE CPP #-} module MagicHaskeller.Analytical.Synthesize where -import Data.List(transpose) +import Data.List(transpose, genericLength, genericTake) -- import Control.Monad.Search.RecompDL -- a version using DList, but did not actually improve the efficiency. import Control.Monad -- hiding (guard) import Control.Monad.State -- hiding (guard) @@ -23,13 +23,17 @@ import MagicHaskeller.Analytical.UniT import MagicHaskeller.Analytical.FMExpr +import Data.Int +import Data.Word + -- | function specification by examples. -data Fun = BKF {maxNumBVs :: Int, arity :: Int, iopairs :: [IOPair], fmexpr :: FMExpr [IOPair]} -- ^ the function is really a background knowledge (and thus there is no need for loop check) - | Rec {maxNumBVs :: Int, arity :: Int, iopairs :: [IOPair], fmexpr :: FMExpr [IOPair], toBeSought :: TBS} -- ^ it is actually a recursive call. +data Fun a = BKF {maxNumBVs :: Int, arity :: Int, iopairs :: [IOPair a], fmexpr :: FMExpr [IOPair a]} -- ^ the function is really a background knowledge (and thus there is no need for loop check) + | Rec {maxNumBVs :: Int, arity :: Int, iopairs :: [IOPair a], fmexpr :: FMExpr [IOPair a], toBeSought :: TBS} -- ^ it is actually a recursive call. mkBKFun iops@(iop:_) = BKF {maxNumBVs = maximum $ map numUniIDs iops, arity = length $ inputs iop, iopairs = iops, fmexpr = iopsToFME iops} mkRecFun ari tbs iops@(iop:_) = Rec {maxNumBVs = maximum $ map numUniIDs iops, arity = ari, iopairs = iops, fmexpr = iopsToVisFME tbs iops, toBeSought = tbs} -- arity = filter id tbs, but it is usually know beforehand +mkInitRecFun iops@(iop:_) = let aritar = length $ inputs iop in mkRecFun aritar (replicate aritar True) iops setIOPairs iops recfun@Rec{toBeSought=tbs} = recfun{iopairs = iops, fmexpr = iopsToVisFME tbs iops} -type BK = [Types.Typed Fun] -- ^ background knowledge. +type BK a = [Types.Typed (Fun a)] -- ^ background knowledge. applyFun s fun = fun{iopairs = applyIOPs s (iopairs fun)} @@ -40,18 +44,19 @@ analyticSynthAndInfType tcl vl target bkdec = case unPS (liftM2 (,) (parseTypedIOPairss tcl xvl target) (parseTypedIOPairss tcl xvl bkdec)) Types.emptySubst 0 of Nothing -> error "Type error occurred while reading the IO pairs." - Just (([],_),_,_) ->error "TypedIOPairs.analyticSynth*: No I/O pairs are defined as the target." + Just (([],_),_,_) ->error "MagicHaskeller.Synthesize.analyticSynth*: No I/O pairs are defined as the target." Just (([(targetFunName, iops@(iop:_) Types.:::ty)],bktups),_,mx) -> let (bknames, bktiopss) = unzip bktups (bkiopss, bktypes) = unzipTyped bktiopss target = mkRecFun aritar tbs iops tbs = replicate aritar True aritar = length $ inputs iop + aritar8 = fromIntegral aritar bk = reverse $ zipWith (Types.:::) (map mkBKFun $ bkiopss) bktypes - in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $ -- $ Fix e $ map X [arity-1, arity-2 .. 0]) $ -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òŬÍѤ·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥ + in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar8 [aritar8-1, aritar8-2..0])) $ -- $ Fix e $ map X [arity-1, arity-2 .. 0]) $ -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òŬÍѤ·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥ fastAnalSynthNoUniT bk (target Types.::: ty) ,foldr (Types.:->) ty bktypes) - _ -> error "TypedIOPairs.analyticSynth*: More than one I/O pairs are defined as the target." + _ -> error "MagicHaskeller.Synthesize.analyticSynth*: More than one I/O pairs are defined as the target." where xvl = mkXVarLib vl @@ -79,7 +84,7 @@ is included. Those bindings are not valid Haskell, nor accepted by Template Haskell, so a library like haskell-src has to be used for parsing them. -} -analSynth, analSynthm, fastAnalSynthNoUniT :: Search m => BK -> Types.Typed Fun -> m CoreExpr +analSynth, analSynthm, fastAnalSynthNoUniT :: Search m => BK a -> Types.Typed (Fun a) -> m CoreExpr analSynth bk tfun@(fun Types.::: _) | any hasExistential $ map output $ iopairs fun = fmap fst $ runStateT (analSynthUTm bk tfun) emptySt | otherwise = analSynthm bk tfun analSynthm bk tfun @@ -89,16 +94,16 @@ others = headSpine analSynthm (introConstr +++ introVarm +++ ndelayIntro 2 introCase) newbk tfun headSpine rec intro bk tfun = do (hd, subfuns, mbpivot) <- intro bk tfun - subexps <- mapM (\subfun -> let arisub = arity $ Types.typee subfun in fmap (\e -> Fix e arisub (mkArgs mbpivot arisub)) $ rec bk subfun) subfuns + subexps <- mapM (\subfun -> let arisub = fromIntegral $ arity $ Types.typee subfun :: Int8 in fmap (\e -> Fix e arisub (mkArgs mbpivot arisub)) $ rec bk subfun) subfuns return (hd subexps) #ifdef DEBUG headSpine_debug rec trs intro bk tfun = do (hd, subfuns, mbpivot) <- intro bk tfun - subexps <- zipWithM (\tr subfun -> let arisub = arity $ Types.typee subfun in fmap (\e -> Fix e arisub (mkArgs mbpivot arisub)) $ rec tr bk subfun) trs subfuns + subexps <- zipWithM (\tr subfun -> let arisub = fromIntegral $ arity $ Types.typee subfun in fmap (\e -> Fix e arisub (mkArgs mbpivot arisub)) $ rec tr bk subfun) trs subfuns return (hd subexps) #endif -analSynthUTm :: Search m => BK -> Types.Typed Fun -> UniT m CoreExpr +analSynthUTm :: Search m => BK a -> Types.Typed (Fun a) -> UniT a m CoreExpr -- analSynthm ([], _, _) = mzero -- If there is no example, nothing can be done. (But is this line necessary?) analSynthUTm bk (fun Types.::: ty) = do @@ -108,10 +113,10 @@ headSpine analSynthUTm introAny newbk aptfun mkArgs Nothing arisub = [arisub-1,arisub-2..0] -mkArgs (Just pivot) arisub = take pivot [arisub,arisub-1..] ++ [arisub-pivot-1,arisub-pivot-2..0] +mkArgs (Just pivot) arisub = genericTake pivot [arisub,arisub-1..] ++ [arisub-pivot-1,arisub-pivot-2..0] #ifdef DEBUG -analyticSynthNoUniT_debug :: Search m => Tree (Introducer m) -> TyConLib -> VarLib -> [Dec] -> [Dec] -> m CoreExpr +analyticSynthNoUniT_debug :: Search m => Tree (Introducer a m) -> TyConLib -> VarLib -> [Dec] -> [Dec] -> m CoreExpr analyticSynthNoUniT_debug tree tcl vl target bkdec = case unPS (liftM2 (,) (parseTypedIOPairss tcl xvl target) (parseTypedIOPairss tcl xvl bkdec)) Types.emptySubst 0 of Nothing -> error "Type error occurred while reading the IO pairs." @@ -133,13 +138,13 @@ data Tree x = Br x [Tree x] deriving Show -tryall, tryVar :: Search m => Tree (IntroUniT m) +tryall, tryVar :: Search m => Tree (IntroUniT a m) tryall = Br introAny (repeat tryall) tryVar = Br introVarUTm [] -tryVarm :: (Functor m, MonadPlus m) => Tree (Introducer m) +tryVarm :: (Functor m, MonadPlus m) => Tree (Introducer a m) tryVarm = Br introVarm [] -analyticSynth_debug :: Search m => Tree (IntroUniT m) -> TyConLib -> VarLib -> [Dec] -> [Dec] -> m CoreExpr +analyticSynth_debug :: Search m => Tree (IntroUniT a m) -> TyConLib -> VarLib -> [Dec] -> [Dec] -> m CoreExpr analyticSynth_debug tree tcl vl target bkdec = do ((tgt,bktups),_,mx) <- unPS (liftM2 (,) (parseTypedIOPairss tcl xvl target) (parseTypedIOPairss tcl xvl bkdec)) Types.emptySubst 0 @@ -158,7 +163,7 @@ where xvl = mkXVarLib vl -- | 'analSynthUT_debug' can be used to try only the given introducer at each selection point. @analSynthUT = analSynthUT_debug tryall@ -analSynthUT_debug :: Search m => Tree (IntroUniT m) -> BK -> Types.Typed Fun -> UniT m CoreExpr +analSynthUT_debug :: Search m => Tree (IntroUniT a m) -> BK a -> Types.Typed (Fun a) -> UniT a m CoreExpr analSynthUT_debug (Br intro iss) bk (fun Types.::: ty) = do s <- gets subst @@ -169,20 +174,20 @@ return (hd subexps) #endif -type Introducer m = BK -> Types.Typed Fun -> m ([CoreExpr] -> CoreExpr, [Types.Typed Fun], Maybe Int) -type IntroUniT m = Introducer (UniT m) --- NB: We should not use @StateT Env@ where @Env=(BK,TBS)@ because the Env affects only subexpressions. +type Introducer a m = BK a -> Types.Typed (Fun a) -> m ([CoreExpr] -> CoreExpr, [Types.Typed (Fun a)], Maybe Int8) +type IntroUniT a m = Introducer a (UniT a m) +-- NB: We should not use @StateT Env@ where @Env=(BK a,TBS)@ because the Env affects only subexpressions. il +++ ir = \bk iops -> il bk iops `mplus` ir bk iops ndelayIntro n intro = \e a -> ndelay n $ intro e a -introAny :: Search m => IntroUniT m +introAny :: Search m => IntroUniT a m introAny = introConstr +++ {- +/ -} ( introVarUTm +++ ndelayIntro 1 introBKUTm +++ ndelayIntro 2 introCase ) -(+/) :: MonadPlus m => IntroUniT [] -> IntroUniT m -> IntroUniT m +(+/) :: MonadPlus m => IntroUniT a [] -> IntroUniT a m -> IntroUniT a m m +/ n = \bk iops -> do st <- get case runStateT (m bk iops) st of [] -> n bk iops @@ -190,9 +195,9 @@ liftList :: MonadPlus m => StateT s [] a -> StateT s m a liftList = mapStateT (msum . map return) -introVarm, introVarm', introConstr, introCase :: (Functor m, MonadPlus m) => Introducer m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥ -introBKm :: (Search m) => Introducer m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥ -introVarUTm, introBKUTm :: MonadPlus m => IntroUniT m +introVarm, introVarm', introConstr, introCase :: (Functor m, MonadPlus m) => Introducer a m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥ +introBKm :: (Search m) => Introducer a m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥ +introVarUTm, introBKUTm :: MonadPlus m => IntroUniT a m -- introVarUTm¤Ï°ìÏ¢¤ÎIgor´Ø·¸¤ÎÏÀʸ¤Ë¤Ï¤Ê¤¤¤â¤Î¤Î¡¤introBK¤¬Í­¸ú¤ËƯ¤¯¤Ë¤ÏɬÍס¥¤³¤ì¤¬¤Ê¤¤¤È¡¤f¤òºî¤ë¤Î¤ËBK¤È¤·¤Æf¤ò»È¤Ã¤Æ¤â¡¤introBK¤À¤±¤Ç½ª¤ï¤Ã¤Æ¤¯¤ì¤º¡¤À¸À®¤µ¤ì¤Ê¤¤¡¥ {- introBK¤Î¤¢¤È¤ÎintroVarUTm¤òintroBK¤Ë´Þ¤á¤è¤¦¤È¤·¤Æ¡¤¤ä¤Ã¤Ñ»ß¤á¤¿¡¥ introVarUTm (iops,_,_,True) = mzero @@ -205,7 +210,7 @@ introVarm' = introVar (zipWithM_ unify) -introVar :: MonadPlus m => ([Expr] -> [Expr] -> m ()) -> Introducer m +introVar :: MonadPlus m => ([Expr a] -> [Expr a] -> m ()) -> Introducer a m introVar cmp _ (fun Types.::: ty) = do let (argtys, retty) = Types.splitArgs ty iops = iopairs fun @@ -230,8 +235,8 @@ iops = iopairs fun in case [ output iop | iop <- iops ] of - outs@(C _ (cid Types.::: cty) flds : rest) - | all (`sConstrIs` cid) rest -> return (foldl (:$) (Primitive cid True), + outs@(C _ _ (cid Types.::: cty) flds : rest) + | all (`sConstrIs` cid) rest -> return (foldl (:$) (PrimCon cid), zipWith (\iops retty -> setIOPairs iops fun Types.::: Types.popArgs argtys retty) (transpose [ divideIOP iop | iop <- iops ]) (case Types.revSplitArgs cty of (_,fieldtys,_) -> fieldtys), @@ -239,11 +244,11 @@ _ -> mzero divideIOP (IOP bvs ins out) = map (IOP bvs ins) $ fields out -- The actual number of buondVars may reduce, but not updating the field would not hurt. -shareConstr (C _ (cid Types.::: _) _ : iops) = all (`sConstrIs` cid) iops +shareConstr (C _ _ (cid Types.::: _) _ : iops) = all (`sConstrIs` cid) iops shareConstr _ = False -- type¤¬°ã¤¦¤ÈƱ¤¸cid¤ò°Û¤Ê¤ëconstructor¤Ç»È¤¤ÆÀ¤ë¾ì¹ç¡¤type¤´¤ÈÈæ³Ó¤¹¤ëɬÍפ¬¤¢¤ë¤¬¡¤¸½ºß¤Ï¤½¤¦¤Ç¤Ï¤Ê¤¤¤Î¤Ç¡¥ -C _ (c Types.::: _) _ `sConstrIs` cid = cid==c -_ `sConstrIs` cid = False +C _ _ (c Types.::: _) _ `sConstrIs` cid = cid==c +_ `sConstrIs` cid = False select [] [] = [] @@ -256,22 +261,24 @@ (argtys,retty) = Types.splitArgs ty iops = iopairs fun arifun = arity fun + {- introCase' :: MonadPlus m => Int -- ^ the pivot position - -> ([Expr],TBS) -- ^ (the pivot expression for each I/O pair, the next TBS) - -> m ([CoreExpr] -> CoreExpr, [Types.Typed Fun], Maybe Int) + -> ([Expr a],TBS) -- ^ (the pivot expression for each I/O pair, the next TBS) + -> m ([CoreExpr] -> CoreExpr, [Types.Typed (Fun a)], Maybe Int) + -} introCase' pos (pivots, tbs) -- includes variable cases. Overlapping patterns are not supported yet. = case mapM maybeCtor pivots of Nothing -> mzero Just ctors -> let - pipairs = zip pivots iops :: [(Expr,IOPair)] + pipairs = zip pivots iops -- :: [(Expr a, IOPair a)] ts = IntMap.toList $ IntMap.fromListWith (\(t,xs) (_,ys) -> (t,xs++ys)) $ - zipWith (\(c Types.::: ct) x -> (c,(ct,[x]))) ctors pipairs - :: [(Constr, (Types.Type, [(Expr,IOPair)]))] + zipWith (\(c Types.::: ct) x -> (fromIntegral c,(ct,[x]))) ctors pipairs + -- :: [(Constr, (Types.Type, [(Expr a,IOPair a)]))] -- Array.accum can also be used instead of IntMap because we can tell the range from that of VarLib. - hd ces = Case (X pos) - (zipWith (\(constr, (_, (pivot,_):_)) ce -> (constr, length (fields pivot), ce)) + hd ces = Case (X $ fromIntegral pos) + (zipWith (\(constr, (_, (pivot,_):_)) ce -> (fromIntegral constr, genericLength (fields pivot), ce)) ts ces) iopss = [ Rec { maxNumBVs = maxNumBVs fun, @@ -281,12 +288,12 @@ toBeSought = newtbs } Types.::: Types.popArgs (dropNth pos argtys) (Types.popArgs (Types.getArgs cty) retty) - | (_c, (cty, nextpipairs@((C _ _ flds', _):_))) <- ts, + | (_c, (cty, nextpipairs@((C _ _ _ flds', _):_))) <- ts, let lenflds = length flds' - iops = [ IOP bvs (reverse flds ++ is) o | (C _ _c flds, IOP bvs is o) <- nextpipairs ] + iops = [ IOP bvs (reverse flds ++ is) o | (C _ _ _c flds, IOP bvs is o) <- nextpipairs ] newtbs = replicate lenflds True ++ tbs ] - in return (hd, iopss, Just (arifun-pos-1)) + in return (hd, iopss, Just (fromIntegral $ arifun - pos-1)) dropNth pos bs = case splitAt pos bs of (tk,_:dr) -> tk ++ dr @@ -315,7 +322,7 @@ -subtractIOPairsFromIOPairsBKUTm :: MonadPlus m => [IOPair] -> Fun -> UniT m [[IOPair]] +subtractIOPairsFromIOPairsBKUTm :: MonadPlus m => [IOPair a] -> (Fun a) -> UniT a m [[IOPair a]] {- subtractIOPairsFromIOPairsBK funs bks = foldr (liftM2 (:)) (return []) $ map (flip subtractIOPairs bks) funs -} @@ -331,7 +338,7 @@ -- ¤Æ¤æ¡¼¤«¡¤Æ⦤Ïbk¤Îarity¤Ç¤Ï¡© subtractIOPairs fun bkpairs = [ iops | bk <- bkpairs, iops <- subtractIOPair fun bk ] -} -subtractIOPairsBKUTm :: MonadPlus m => IOPair -> Fun -> UniT m [IOPair] -- Æ⦥ꥹ¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤« +subtractIOPairsBKUTm :: MonadPlus m => IOPair a -> (Fun a) -> UniT a m [IOPair a] -- Æ⦥ꥹ¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤« -- ¤Æ¤æ¡¼¤«¡¤Æ⦤Ïbk¤Îarity¤Ç¤Ï¡© subtractIOPairsBKUTm tgt bkf = do s <- gets subst @@ -339,9 +346,9 @@ apbkf = applyIOPs s $ iopairs bkf bkiop <- msum $ map return apbkf subtractIOPairUTm aptgt bkiop -subtractIOPairsFromIOPairsUTm :: MonadPlus m => TermStat -> Fun -> Fun -> UniT m [[IOPair]] +subtractIOPairsFromIOPairsUTm :: MonadPlus m => TermStat -> Fun a -> Fun a -> UniT a m [[IOPair a]] subtractIOPairsFromIOPairsUTm ts tgt bkf = subtractIOPairsFromIOPairsUTm' ts (iopairs tgt) bkf -subtractIOPairsFromIOPairsUTm' :: MonadPlus m => TermStat -> [IOPair] -> Fun -> UniT m [[IOPair]] +subtractIOPairsFromIOPairsUTm' :: MonadPlus m => TermStat -> [IOPair a] -> Fun a -> UniT a m [[IOPair a]] {- subtractIOPairsFromIOPairs funs bks = foldr (\fun rest -> do iops <- subtractIOPairs fun bks iopss <- rest @@ -352,7 +359,7 @@ (iops,newts) <- subtractIOPairsUTm ts fun bkf iopss <- subtractIOPairsFromIOPairsUTm' newts funs bkf -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥ return (iops:iopss) -subtractIOPairsUTm :: MonadPlus m => TermStat -> IOPair -> Fun -> UniT m ([IOPair], TermStat) -- Æ⦥ꥹ¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤« +subtractIOPairsUTm :: MonadPlus m => TermStat -> IOPair a -> (Fun a) -> UniT a m ([IOPair a], TermStat) -- Æ⦥ꥹ¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤« -- ¤Æ¤æ¡¼¤«¡¤Æ⦤Ïbk¤Îarity¤Ç¤Ï¡© subtractIOPairsUTm ts tgt bkf = do s <- gets subst @@ -374,7 +381,7 @@ -- join [x,y] [z,w] = bk (f [x,y] [z,w]) (g [x,y] [z,w])¤Ë¤ª¤¤¤Æf [x,y] [z,w] = [x,z], g [x,y] [z,w] = [y,w]¤Ê¤Î¤Ç¡¤ -- subtractIOPair IOP{inputs=[[x,y],[z,w]],output=[x,y,z,w]} IOP{inputs=[[a,b],[c,d]],output=[a,c,b,d]} = [IOP{inputs=[[x,y],[z,w]],output=[x,z]}, IOP{inputs=[[x,y],[z,w]],output=[y,w]}] -- ¤È¤¤¤¦¤³¤È¤Ë¤Ê¤ë¡¥ -subtractIOPairUTm :: MonadPlus m => IOPair -> IOPair -> UniT m [IOPair] +subtractIOPairUTm :: MonadPlus m => IOPair a -> IOPair a -> UniT a m [IOPair a] subtractIOPairUTm fun bkiop = do frbkiop <- freshIOP bkiop unifyUT (output frbkiop) (output fun) @@ -382,11 +389,11 @@ return [ fun{output=apply s o} | o <- inputs frbkiop ] -- This @apply@ is necessary here because introBKm will soon forget the substitution. subtractIOPairsFromIOPairsm :: Int -- maxNumBVs¤Ç¥²¥Ã¥È¤Ç¤­¤ëÃÍ¡¥ - -> TermStat -> Fun -> Fun -> [] [[IOPair]] + -> TermStat -> Fun a -> Fun a -> [] [[IOPair a]] subtractIOPairsFromIOPairsm addendum ts tgt bkf = subtractIOPairsFromIOPairsmFME addendum ts (length $ filter id $ toBeSought tgt) -- the actual arity (iopairs tgt) bkf addendum -subtractIOPairsFromIOPairsmFME :: Int -> TermStat -> Int -> [IOPair] -> Fun -> Int -> [] [[IOPair]] +subtractIOPairsFromIOPairsmFME :: Int -> TermStat -> Int -> [IOPair a] -> Fun a -> Int -> [] [[IOPair a]] {- subtractIOPairsFromIOPairsBK funs bks = foldr (liftM2 (:)) (return []) $ map (flip subtractIOPairs bks) funs -} @@ -397,7 +404,7 @@ return (iops:iopss) -- Applying substitutions to funs is not currently necessary (because funs does not include existential variables), but that will be useful in future versions which fill gaps of input examples. -subtractIOPairsmFME :: TermStat -> Int -> IOPair -> Fun -> Int -> [([IOPair], TermStat)] -- ÊÖ¤êÃͤÎ[IOPair]¤Ï³Æ°ú¿ô¤ËÂбþ +subtractIOPairsmFME :: TermStat -> Int -> IOPair a -> Fun a -> Int -> [([IOPair a], TermStat)] -- ÊÖ¤êÃͤÎ[IOPair]¤Ï³Æ°ú¿ô¤ËÂбþ subtractIOPairsmFME ts ary tgtiop bkf offset = case output tgtiop of E{} -> [(replicate (arity bkf) tgtiop, ts)] -- target¤ÎÊÖ¤êÃͤ¬Ã±¤Ëexistential variable¤Î¾ì¹ç¡¤»È¤ï¤ì¤Ê¤¤¤Î¤Ç¤Ê¤ó¤Ç¤â¤è¤¤¡¥¤¬¡¤arity¤ò·¤¨¤ëɬÍפ¬¤¢¤ë¡¥ tgto -> do @@ -411,9 +418,9 @@ subtractIOPairsFromIOPairsBKm :: Int -- maxNumBVs¤Ç¥²¥Ã¥È¤Ç¤­¤ëÃÍ¡¥ - -> [IOPair] -> Fun -> [] [[IOPair]] + -> [IOPair a] -> (Fun a) -> [] [[IOPair a]] subtractIOPairsFromIOPairsBKm addendum tgt bkf = subtractIOPairsFromIOPairsBKmFME addendum tgt (iopsToFME $ iopairs bkf) addendum -subtractIOPairsFromIOPairsBKmFME :: Int -> [IOPair] -> FMExpr [IOPair] -> Int -> [] [[IOPair]] +subtractIOPairsFromIOPairsBKmFME :: Int -> [IOPair a] -> FMExpr [IOPair a] -> Int -> [] [[IOPair a]] {- subtractIOPairsFromIOPairsBK funs bks = foldr (liftM2 (:)) (return []) $ map (flip subtractIOPairs bks) funs -} @@ -426,12 +433,12 @@ -subtractIOPairsBKmFME :: IOPair -> FMExpr [IOPair] -> Int -> [] [IOPair] -- ÊÖ¤êÃͤÎ[IOPair]¤Ï³Æ°ú¿ô¤ËÂбþ +subtractIOPairsBKmFME :: IOPair a -> FMExpr [IOPair a] -> Int -> [] [IOPair a] -- ÊÖ¤êÃͤÎ[IOPair a]¤Ï³Æ°ú¿ô¤ËÂбþ subtractIOPairsBKmFME tgtiop bkfme offset = do visbkis <- unifyingIOPairs (output tgtiop) bkfme offset return [ tgtiop{output=o} | o <- visbkis ] -unifyingIOPairs :: Expr -> FMExpr [IOPair] -> Int -> [] [Expr] +unifyingIOPairs :: Expr a -> FMExpr [IOPair a] -> Int -> [] [Expr a] unifyingIOPairs e fme 0 = [ inputs iop | (iops, _) <- unifyFME e fme, iop <- iops ] unifyingIOPairs e fme offset = [ map (mapE (offset+) . apfresh s) $ inputs iop | (iops, s) <- unifyFME e fme, iop <- iops ] diff --git a/MagicHaskeller/Analytical/UniT.hs b/MagicHaskeller/Analytical/UniT.hs --- a/MagicHaskeller/Analytical/UniT.hs +++ b/MagicHaskeller/Analytical/UniT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} -- -- (C) Susumu Katayama -- @@ -8,28 +9,29 @@ import MagicHaskeller.Analytical.Syntax -type UniT = StateT St -data St = St {subst::Subst, nextVar :: Int} deriving Show +type UniT a = StateT (St a) +data St a = St {subst::Subst a, nextVar :: Int} deriving Show emptySt = St {subst=[], nextVar=0} - +{- freshVar :: Monad m => UniT m Expr freshVar = do st <- get let nv = nextVar st put st{nextVar = succ nv} return $ E nv +-} freshIOP (IOP n ins out) = do st <- get let nv = nextVar st put st{nextVar = nv + n} return $ IOP 0 (map (fresh (nv+)) ins) (fresh (nv+) out) -applyUT :: Monad m => Expr -> UniT m Expr +applyUT :: Monad m => Expr a -> UniT a m (Expr a) applyUT ex = do s <- gets subst return $ apply s ex applyIOPUT iop = do s <- gets subst return $ applyIOP s iop -unifyUT :: MonadPlus m => Expr -> Expr -> UniT m () +unifyUT :: MonadPlus m => Expr a -> Expr a -> UniT a m () unifyUT e1 e2 = case unify e1 e2 of Just s -> modify (\st -> st{subst = s `plusSubst` subst st}) Nothing -> mzero {- Obviously this is slower, but I do not remember why I used this. diff --git a/MagicHaskeller/CGI.lhs b/MagicHaskeller/CGI.lhs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/CGI.lhs @@ -0,0 +1,614 @@ +#!/usr/bin/runhaskell + +Compile with +ghc -O CGI.lhs -o MagicHaskeller.cgi -package cgi -package mueval -package hint --make -DGHC7 + +Also, timeout has to be implemented! + + +The running version of lighttpd ignores stderr, so logCGI actions does not work. +(I checked it using a CGI program written in C.) + +\begin{code} +{-# LANGUAGE CPP #-} +module MagicHaskeller.CGI(main', simpleMain) where +import System.IO +import Network +import Network.CGI hiding (Language) +import Data.Char +import Data.Maybe(isJust) +import Data.List(nub, dropWhileEnd) +import System.Environment(getProgName) +import Prelude hiding (catch) +import Control.Monad(when) +import Control.Concurrent +import Control.Exception.Extensible(catch, SomeException(SomeException)) +import System.Timeout +import Text.Html +#ifdef UNIX +import Mueval.Interpreter +import Mueval.ArgsParse +import Mueval.Context +import Mueval.Parallel +#endif +import Language.Haskell.Interpreter + +import MagicHaskeller.ExpToHtml + +import Language.Haskell.Parser +import Language.Haskell.Syntax + +-- | The name of the config file. Nothing means the default name, which is ".conf" +mbConfigFileName = Nothing +-- mbConfigFileName = Just "MagicHaskeller.conf" + +data Config = C {computerLanguage :: Language, + portID :: PortID, hostname :: String, maximalDepth :: Int, + myPath :: String, -- The user writes a path here, but internally the progName will be added. + minimalDepth :: Int, pagesize :: Int, -- These two should be customizable, but anyway, server default should exist. + needSignature :: Bool -- 'needSignature' should be True if using GHC<7.6 ON THE SERVER SIDE. (So this cannot be determined by __GLASGOW_HASKELL__.) + } deriving Read +-- Unfortunately, the Read instance of PortID is not defined in the library! +instance Read PortID where + readsPrec _ str = case lex str of +#ifdef UNIX + [("UnixSocket", strrest)] -> [ (UnixSocket str, rest) | (str, rest) <- reads strrest ] +#endif + [("PortNumber", numrest)] -> [ (PortNumber $ fromInteger num, rest) | (num, rest) <- reads numrest ] + _ -> [] + +defaultConfig :: Config +defaultConfig = C { + computerLanguage = LHaskell, + -- portID = UnixSocket "/usr/lib/cgi-bin/MagicHaskeller/mhserver" + portID = PortNumber 55444, + hostname = "localhost", + -- hostname = "133.54.228.70" + maximalDepth = depth defaultQO, + --myPath = "/cgi-bin/MagicHaskeller-ghc7.4.1.cgi" + --myPath = "/cgi-bin/MagicHaskeller.cgi" + myPath = "/cgi-bin/", + minimalDepth = 3, -- shown at once + pagesize = 30, + needSignature = False + } + +configToTitle = languageToTitle . computerLanguage +languageToTitle LHaskell = "MagicHaskeller on the Web" +languageToTitle LExcel = "MagicExceller Server" +languageToTitle LJavaScript = "MagicJavaScripter" + +firstlines config showAbsents predicate = + "" ++ + " " ++ + " " ++ configToTitle config ++ " " ++ + " \n" ++ + " \n" ++ + " " ++ + " " ++ + "

" ++ configToTitle config ++ "

" ++ + "
(CGI frontend version " ++ versionInfo ++ ")
" ++ + " Specify a function f by writing a predicate as a boolean-valued expression. You will get functions generalizing the specification.
" + ++ predicateBox (myPath config) "90" showAbsents predicate + ++ (case computerLanguage config of + LHaskell -> "Help, examples, etc. in English / in Japanese" + LExcel -> "Help, examples, etc. in English / in Japanese") +-- We want to show the following button only when Javascript is enabled. +absentButton True = + " " +absentButton False = "" + +-- The title was (and will be) function details, but currently it is not the right phrase. +detailsHead config = + "" ++ + " " ++ + " " ++ configToTitle config ++ " --- input-output examples " ++ + " " + ++ detailsStyle ++ + " " ++ + " " ++ + "

" ++ configToTitle config ++ " --- input-output examples

" +detail config predicate = detailsHead config ++ "The candidate expression
" ++ detail' config predicate + +thanksHead config = + "" ++ + " " ++ + " " ++ configToTitle config ++ " --- Thanks! " ++ + " " + ++ detailsStyle ++ + " " ++ + " " ++ + "

Thank you for the feedback!

" +-- | a variant of @detail@ thanking for a suggestion +thanks config predicate = "By the way, the submitted expression
" ++ detail' config predicate + +detailsStyle = + " " + + +detail' config predicate = + "
" ++ + " f = " ++ + "
" ++ + "
satisfies the following input-output relation:

" +-- about `display: inline;', See newnotes on Nov. 1, 2012 and http://www.cs.tut.fi/~jkorpela/forms/extraspace.html +-- input-output examples²èÌ̤Çabsentbox¤òɽ¼¨¤·¤Æ¤â¥´¥Á¥ã¥´¥Á¥ã¤¹¤ë¤À¤±¤Ê¤Î¤Ç¡¤±£¤·¤Æ¤ª¤¯¡¥ +-- Ãí*1 #absentbox¤Î¤È¤³¤í¤Ï¡¢²¼µ­¤Î*1¤Ç½ñ¤¤¤¿ÌäÂê¤ò²ò·è¤·¤Æ¤«¤é¥Æ¥¹¥È¤·¤¿¤¤¤Î¤Ç¡¤¤½¤Î»þ¤Ïdisplay: none¤Ç¤Ï¤Ê¤¯font-size: small¤Ë¤·¤Æ¤«¤é¥Á¥§¥Ã¥¯¤·¤Æ¤ª¤­¤¿¤¤¡¥ + +-- details ¤Î²èÌ̤ÇboxÆâ¤ò¥«¥Ã¥³¤Ç¤¯¤¯¤ëworkaround. ËÜÅö¤Ï¥µ¡¼¥Ð¡¼Â¦¤ÇºÇ½é¤«¤é¥«¥Ã¥³¤Ç¤¯¤¯¤Ã¤Æ¤ª¤¤¤¿Êý¤¬²ó¤ê¤¯¤É¤¯¤Ê¤¤¡¥ +parenthesize xs | last xs == ')' = xs -- ¥¯¥¨¥ê¡¼Ëè¤Ë¥«¥Ã¥³¤¬Áý¤¨¤Æ¤¤¤«¤Ê¤¤¤è¤¦¤Ë¡¤¤¹¤Ç¤Ë¥«¥Ã¥³¤¬¤¢¤ë¤È»×¤ï¤ì¤ë¤È¤­¤Ï³ç¤é¤Ê¤¤¡¥ + | otherwise = '(':xs++")" + +predicateBox myPathName size showAbsents predicate = queryBox myPathName size showAbsents predicate "Synthesize f" +queryBox myPathName size showAbsents predicate label + = "
" ++ + " " ++ + "
show functions with unused arguments
" ++ + " " ++ + "
" + +escapeQuote '\'' = "'" +escapeQuote c = [c] +examplePredicate = " f \"abcde\" 2 == \"aabbccddee\" " + +more myPathName d sa p = "
" ++ + " " ++ + absentInput sa ++ + " " ++ + " " ++ + "
" +next myPathName pg sa p = "
" ++ + " " ++ + absentInput sa ++ + " " ++ + " " ++ + "
" + +absentInput True = "" +absentInput False = "" + +lastLines True = "" ++ + "" +lastLines False = "" + +unavailable config = detailsHead config ++ "

We are sorry, but this functionality is not provided by the CGI frontend built for non-UNIX servers.

" ++ lastLines False + +main = main' runCGI +main' run = do + progName <- getProgName + let configFileName = maybe (dropWhileEnd (/='.') progName ++ "conf") id mbConfigFileName + config <- do str <- readFile configFileName + return $ readUrk str + `catch` \(SomeException _) -> do hPutStrLn stderr $ "Warning: could not read the config file" ++ shows configFileName ". Using the default." + return defaultConfig + run (handleErrors (cgiMain $ config{myPath = myPath config ++ progName})) +simpleMain = do progName <- getProgName + runCGI (handleErrors $ simpleCgiMain $ defaultConfig{myPath = myPath defaultConfig ++ progName}) +cgiMain, simpleCgiMain :: Config -> CGI CGIResult +cgiMain config + = let myPathName = myPath config + in do -- firstlines <- liftIO $ readFile "firstlines" + mbXL <- getInput "xl" + let useJS = case computerLanguage config of LHaskell -> not $ isJust mbXL -- if MagicHaskeller.cgi is called with xl=1, disable JavaScript in order to pass the XSS filter of Internet Explorer. + _ -> True + mbAbsent <- getInput "absent" + let showAbsents = isJust mbAbsent + mbPred <- getInput "predicate" + case mbPred of + Just command@(':':_) -> passCommand config showAbsents command -- Just pass it if it is a command. (But be careful about any danger.) + -- If unknown commands are also passed without any checking, the backend server must check them and print an error message when necessary. + Just predicate + | all isSpace predicate -> defaultPage config + | otherwise -> do + let qBox = queryBox myPathName (show $ length predicate `max` 10) showAbsents predicate + predBox = qBox "Synthesize f" + mbCandi <- getInput "candidate" + case mbCandi of + Nothing -> + case lex predicate of + [(word@(w:_),"")] | isAlpha w || w `elem` "=+!@#$%^&*-\\|:/?<>.~" -> do setHeader "Location" $ snd $ refer word + outputNothing + _ -> do setHeader "Content-type" "text/html" + if faru predicate + then organizeSynthesis config showAbsents predicate useJS + else +#ifdef UNIX + case fixCandidate predicate of + Left msg -> output $ detail config predicate ++ stringToHtmlString msg ++ lastLines useJS + Right (candi, fxd)-> do + -- liftIO $ putStrLn "Exemplifying the user-supplied expression..." + mbresult <- liftIO $ runErr $ "showIOPairsHTML \"f\" (generateIOPairs ("++candi++"))" + -- liftIO $ putStrLn "exemplified." + logCGI $ "MagHLogUser " ++ candi + case mbresult of Left msg -> output $ detailsHead config ++ blameQuery (qBox "Exemplify") msg ++ lastLines False + Right result -> output $ detail config candi ++ ""++result ++"
"++ lastLines useJS +#else + output $ unavailable config +#endif + Just candi -> +#ifdef UNIX + do -- liftIO $ putStrLn "Exemplifying the synthesized expression..." +-- result <- liftIO $ genIOPs $ ("showIOPairsWithFormsHTML "++show myPathName++" ")++shows predicate (" \"f\" (generateIOPairs ("++candi++"))") -- This is not good unless the type signature is added, because type variables would be instantiated to (). + eitherResult <- liftIO $ runErr $ ("showIOPairsWithFormsHTML "++show myPathName++" ")++shows predicate (" \"f\" (generateIOPairs (let {f = const ("++candi++") ("++predicate++")} in f))") + + mbSug <- getInput "suggest" + let suggesting = isJust mbSug + errHead | suggesting = blameSuggestion candi predicate + | otherwise = apologize + logCGI $ (if suggesting then "MagHLogSuggest " else "MagHLogSynth ") ++ candi ++ " ;; " ++ predicate + + case eitherResult of + Left msg -> output $ (if suggesting then thanksHead else detailsHead) config ++ errHead msg ++ lastLines False + Right result -> do + bs <- liftIO $ runErr ("let {f = " ++ candi ++ "} in " ++ predicate) + case bs of + Left msg -> do logCGI $ "MagHLogErr " ++ msg + output ((if suggesting then thanksHead else detailsHead) config ++ errHead msg ++ lastLines False) + Right b -> do let pb = if b then predBox else "not ("++predBox++")" + when (not b) $ logCGI $ "MagHLogErr " ++ pb + output ((if suggesting then thanks else detail) config candi ++ pb ++ "
"++result ++"
"++ lastLines useJS) --
is necessary for Safari. + -- Exemplify¥Ü¥¿¥ó¤¬¤Á¤ã¤ó¤Èabsent¤òÀßÄꤷ¤Æ¤¤¤Ê¤¤¤Î¤Ç¡¤showAbsents¤òÁ÷¤Ã¤Æ¤â¤¢¤Þ¤ê°ÕÌ£¤¬¤Ê¤¤¡¥Ãí*1 +#else + output $ unavailable config +#endif + Nothing -> defaultPage config + +-- blameQuery predBox = "I'm afraid that the expression " ++ predBox ++ " you provided is an invalid Haskell expression, or has an unexpected type." ++ ghcComplaint +-- blameSuggestion candidate = "I'm afraid that your candidate expression
" ++ candidate ++ "
is either invalid as a Haskell expression or inconsistent with the type of the predicate." +-- ++ ghcComplaint +-- apologize = "I'm sorry but the candidate expression is inconsistent with the given predicate. Please let me know if this situation is caused just by clicking an autogenerated button." ++ ghcComplaint +-- ghcComplaint = "GHC complained with the following error message:" + + +blamePredicate predBox msg = "I'm afraid that the expression
" ++ predBox ++ "
caused some error(s):
" ++ msg ++ "
If you do not understand the error message, please check your expression's validity as a Haskell expression, and make sure that it is a type-consistent unary function returning a boolean value." +blameQuery predBox msg = "I'm afraid that the expression
" ++ predBox ++ "
caused some error(s):
" ++ msg ++ "
If you do not understand the error message, please check your expression's validity as a Haskell expression and type consistency with the type of the predicate, and make sure it does not cause an infinite loop." +blameSuggestion candidate predicate msg = "However, I'm afraid that your candidate expression
" ++ candidate ++ "
with your predicate
" ++ predicate ++ "
caused some error(s):
" ++ msg ++ "
If you do not understand the error message, please check your expressions' validity and type consistency as Haskell expressions, and make sure they do not cause an infinite loop." +apologize msg = "I'm sorry but the candidate expression with the predicate causes some error(s):
" ++ msg ++ "
Please let me know if this situation is caused just by clicking an autogenerated button." + +\end{code} + + +"Do you mean?" functionality for I/O example query expressions. +This balances parens by adding some, and lambda-binds free alphabetic 1-letter variables. + +Even then, the problem of type variable ambiguity may occur. +\begin{code} +parseExpr e = case parseModule $ "x= "++e of -- This is a pattern binding, not a function binding. + -- The space after x= is necessary. Without it "x=\a->..." causes parse error. + ParseOk (HsModule _ _ _ _ [HsPatBind _ _ (HsUnGuardedRhs hsexp) _]) -> Right hsexp + ParseFailed _loc msg -> Left msg +countParens (HsParen e) = succ $ countParens e +countParens e = 0 + +fixCandidate :: String -> Either String (String, Bool) +fixCandidate xs = case balance xs of Left msg -> Left msg + Right tri -> Right $ bind tri + +balance :: String -> Either String (String, HsExp, Bool) -- Left msg if no parse is possible even after fix; + -- Right (str, hse, True) if parens are added. +balance xs = let numKokka = count ')' xs + numKakko = count '(' xs + balanced = replicate numKokka '(' ++ xs ++ replicate numKakko ')' + in case parseExpr xs of -- We need this step because parentheses can be in Char and String literals. + Left msg -> case parseExpr balanced of + Left _m -> Left msg + Right parened -> let redundancy = countParens parened + in Right (dropNChars redundancy '(' $ reverse $ dropNChars redundancy ')' $ reverse balanced, + parened, True) + Right hse -> Right (xs, hse, False) + +dropNChars 0 _ xs = xs +dropNChars n c (x:xs) | c==x = dropNChars (pred n) c xs + | isSpace x = dropNChars n c xs +dropNChars _ _ _ = error "while balancing: cannot happen." + + +bind :: (String, HsExp, Bool) -> (String, Bool) +bind (xs, hse, chg) = case freeVars hse of [] -> (xs, chg) + names -> ("(\\"++unwords names++" -> "++xs++")", True) +-- freeVars obtains the list of unbound 1-letter alphabetic variable names. +freeVars hse = nub $ fv [] hse [] +fv bounds (HsInfixApp e0 qop e1) = fv bounds e0 . freeVarsQOp bounds qop . fv bounds e1 +fv bounds (HsApp e0 e1) = fvList bounds [e0,e1] +fv bounds (HsNegApp e) = fv bounds e +fv bounds (HsLambda _ pats e) = fv (boundVars pats bounds) e +-- fv bounds (HsLet decls e) = -- bothered. +fv bounds (HsIf b t f) = fvList bounds [b,t,f] +fv bounds (HsCase e alts) = fv bounds e -- I ignore alts. I am just tired. +-- fv bounds (HsDo stmts) = +fv bounds (HsTuple es) = fvList bounds es +fv bounds (HsList es) = fvList bounds es +fv bounds (HsParen e) = fv bounds e +fv bounds (HsLeftSection e qop) = fv bounds e . freeVarsQOp bounds qop +fv bounds (HsRightSection qop e) = freeVarsQOp bounds qop . fv bounds e +fv bounds (HsRecConstr _con updates) = fvRecord bounds updates +fv bounds (HsRecUpdate e updates) = fv bounds e . fvRecord bounds updates +fv bounds (HsEnumFrom e) = fv bounds e +fv bounds (HsEnumFromTo e0 e1) = fvList bounds [e0,e1] +fv bounds (HsEnumFromThen e0 e1) = fvList bounds [e0,e1] +fv bounds (HsEnumFromThenTo e0 e1 e2) = fvList bounds [e0,e1,e2] +-- fv bounds (HsListComp e stmts) = +fv bounds (HsExpTypeSig _loc e _qty) = fv bounds e +fv bounds (HsVar (UnQual (HsIdent name@[_]))) | not $ name `elem` bounds = (name:) +fv bounds _ = id +fvList bounds = foldr (.) id . map (fv bounds) +fvRecord bounds updates = fvList bounds [ e | HsFieldUpdate _ e <- updates ] + +freeVarsQOp bounds (HsQVarOp (UnQual (HsIdent name@[_]))) | not $ name `elem` bounds = (name:) +freeVarsQOp _ _ = id +boundVars [] = id +boundVars (HsPNeg p : pats) = boundVars (p:pats) +boundVars (HsPInfixApp p0 op p1 : pats) = qNameToStrs op . boundVars (p0:p1:pats) +boundVars (HsPApp _con ps : pats) = boundVars ps . boundVars pats +boundVars (HsPTuple ps : pats) = boundVars ps . boundVars pats +boundVars (HsPList ps : pats) = boundVars ps . boundVars pats +boundVars (HsPParen p : pats) = boundVars (p:pats) +boundVars (HsPRec _con patfields : pats) = boundVars [ p | HsPFieldPat _name p <- patfields ] . boundVars pats +boundVars (HsPAsPat name p : pats) = nameToStrs name . boundVars (p:pats) +boundVars (HsPIrrPat p : pats) = boundVars (p:pats) +boundVars (HsPVar (HsIdent name@[_]) : pats) = (name:) . boundVars pats +boundVars (_ : pats) = boundVars pats + +qNameToStrs :: HsQName -> [String] -> [String] +qNameToStrs (UnQual (HsIdent name@[_])) = (name:) +qNameToStrs _ = id +nameToStrs :: HsName -> [String] -> [String] +nameToStrs (HsIdent name@[_]) = (name:) +nameToStrs _ = id + +count :: Char -> String -> Int +count = (\a b -> length (filter (== a) b)) -- synthesized by MagicHaskeller on the Web:) +\end{code} + +\begin{code} +showError config predicate message = output $ firstlines config False predicate ++ message ++ lastLines False + +organizeSynthesis config showAbsents predicate useJS = do + mbIns <- getInput "inputs" + mbOut <- getInput "output" + let augPred + = case (mbIns, mbOut) of + (Nothing, Nothing) -> predicate + (Just ins, Just out) -> let str = ") && f "++ins++" ~= "++out + in '(':predicate++str + _ -> error "Only one of 'inputs' and 'output' is set." + + case review augPred of + Nothing -> + showError config augPred + "

Error: let expressions and where clauses are prohibited here. You can still use case expressions without where clauses for non-recursive bindings.
" + Just (predi, corrected) -> + if needSignature config + then case addSignature predi of + [] -> showError config augPred "

lex error
" + [sigPred] -> organizeSynthesis' config True showAbsents predi sigPred useJS + else organizeSynthesis' config corrected showAbsents predi predi useJS + +organizeSynthesis' config corrected showAbsents predicate sigPred useJS = do + mbPage <- readInput "page" + mbDepth <- readInput "depth" + + mbDepthBound <- readInput "depthbound" -- This is used by MagicExceller, for controling the vertical synthesis. +-- let neocon = config{maximalDepth = maybe (maximalDepth config) id mbDepthBound} + +-- let reqDepth = min maximalDepth $ 1 + maybe (maybe minimalDepth (const maximalDepth) mbPage) id mbDepth + let reqDepth = maximalDepth config -- See notes on Apr. 25, 2013 + theReqDepth = maybe reqDepth id mbDepthBound -- `min` reqDepth + + result <- liftIO $ synthesize config $ shows Q{depth = theReqDepth, absents = showAbsents} sigPred + + let body = case result of '!':res -> "

"++blamePredicate predicate res + _ -> notice++clipped + results = lines result + notice | corrected = "

Results:
(Interpreted as "++stringToHtmlString sigPred++")

" + | otherwise = "

Results:

" + clipped = case mbPage of + Nothing -> case mbDepthBound of + Nothing -> let shownDepth = maybe (minimalDepth config) id mbDepth + in byDepth config shownDepth showAbsents results predicate useJS + Just shownDepth -> + byDepthBound config shownDepth (showAbsents && useJS) results predicate + Just pg -> absentButton (showAbsents && useJS) ++ + case takeNFORMs (pagesize config) (dropNFORMs (pred pg * pagesize config) result) of + (True, sc) -> sc ++ next (myPath config) (succ pg) showAbsents predicate + (False,sc) -> sc + output $ firstlines config showAbsents predicate ++ body ++ lastLines useJS + +passCommand config showAbsents command = do + result <- liftIO $ synthesize config command + output $ firstlines config showAbsents command ++ "

" ++ result ++ lastLines False + +defaultPage :: Config -> CGI CGIResult +defaultPage config = do + setHeader "Content-type" "text/html" + showError config "" "" + +stringToHtmlStringBr = concatMap (\c -> case c of {'\n' -> "
";_->[c]}) . stringToHtmlString + + +#ifdef UNIX +-- hack for extracting Mueval.ArgsParse.defaultOptions which is not exported. This is useful for supporting both mueval<0.9 and mueval>=0.9. +Right defaultOptions = interpreterOpts [] +-- Functions causing infinite loop should be excluded, and I guess use of Safe Haskell is against this (future) policy. + +options = defaultOptions{ + modules = Just ["MagicHaskeller.IOGenerator","Prelude","Data.List","Data.Char","Data.Maybe","Data.Either","MagicHaskeller.FastRatio","MagicHaskeller.LibExcel"] + , timeLimit = 5 + , user = "" + , loadFile = "" + , printType = False + , extensions = False + , namedExtensions = [] + , noImports = False + , rLimits = False + , help = False } + +-- unused +genIOPs :: String -> IO String +genIOPs expr = do result <- runErr expr + return $ case result of Left msg -> msg + Right xs -> xs +runErr :: Read a => String -> IO (Either String a) +runErr expr = do result <- block run options{expression=expr} + return $ case result of Left (WontCompile es) -> Left $ stringToHtmlStringBr $ unlines $ map errMsg es + Left e -> Left $ stringToHtmlStringBr $ show e + Right (_,_,result) -> Right $ readUrk result + `catch` + (\e -> return $ Left $ stringToHtmlStringBr $ show (e::SomeException)) +{- This is not always forcible. +genIOPs expr = do mb <- timeout 2000000 $ -- two seconds. too short? + do result <- runInterpreter $ interpreter $ options{expression="showIOPairs \"
\" \"f\" ("++expr++")"} + case result of Left e -> return $ show e + Right (_,_,result) -> return result + return $ maybe "Timeout occurred.
" id mb + `catch` + (return . show) +-} +run opts mvar = do mainId <- myThreadId + watchDog (timeLimit opts) mainId + hSetBuffering stdout NoBuffering + + -- Our modules and expression are set up. Let's do stuff. + forkIO $ ((runInterpreter . interpreter) opts + >>= putMVar mvar) + `catch` \e -> throwTo mainId (e::SomeException) +#endif + +byDepth config depth showAbsents results predicate useJS + = let + myPathName = myPath config + thatsitblah = thatsit myPathName predicate + in case splitAt depth results of + (tk,[]) | all null tk -> thatsitblah + | otherwise -> absentButton (showAbsents && useJS) ++ unlines tk ++ thatsitblah + (tk,_) | all null tk || null (last tk) -> byDepth config (succ depth) showAbsents results predicate useJS + | otherwise -> absentButton (showAbsents && useJS) ++ + let cl = unlines tk + in case takeNFORMs (pagesize config) cl of + (False,_) -> cl ++ if depth >= maximalDepth config then thatsitblah else more myPathName (succ depth) showAbsents predicate + (True,sc) -> sc ++ next myPathName 2 showAbsents predicate +byDepthBound config depth showAbsents results predicate + = let + myPathName = myPath config + thatsitblah = thatsit myPathName predicate + in case splitAt depth results of + (tk, _) | all null tk -> thatsitblah + | otherwise -> absentButton showAbsents ++ unlines tk ++ thatsitblah + +{- +-- -- The downloadable version is not updated for a while.... +-- thatsit = "
That's it! More (or less) results may be obtained with the downloadable version.
" +thatsit = "
That's it! Please let me know if you think some expression should be synthesized, but isn't.
" +-} +thatsit myPathName predicate + = "
That's it! Please submit the right expression in your mind (or your partial solution as a subexpression) if you like." ++ + " It will be regarded as your suggestion, and may be able to be synthesized by future versions.
" ++ + "

" ++ + " f = " ++ + " " ++ + "
" +faru xs = case lex xs of [] -> False + [("",_)] -> False + [("f",_)] -> True + [(_,ys)] -> faru ys + +addSignature xs = do (cs,rest) <- lex xs + case cs of "" -> return "" + c:cs' | isDigit c && all (/='.') cs' + -> do (token,rest2) <- lex rest + case token of "::" -> fmap ((cs++).("::"++)) $ addSignature rest2 + _ -> fmap (('(':).(cs++).("::Int)"++)) $ addSignature rest + | otherwise -> fmap ((cs++).(' ':)) $ addSignature rest + +-- splitAtNBRs¤Ë¤¹¤ì¤Ð¤è¤«¤Ã¤¿¡¥ + +takeNBRs 0 _ = (True, "") +takeNBRs n "" = (False,"") +takeNBRs n ('<':'b':'r':'>':xs) = case takeNBRs (pred n) xs of (b,r) -> (b, "
" ++ r) +takeNBRs n (x:xs) = case takeNBRs n xs of (b,r) -> (b, x : r) + +dropNBRs 0 xs = xs +dropNBRs n "" = "" +dropNBRs n ('<':'b':'r':'>':xs) = dropNBRs (pred n) xs +dropNBRs n (x:xs) = dropNBRs n xs + +takeNFORMs 0 _ = (True, "") +takeNFORMs n "" = (False,"") +takeNFORMs n ('<':'/':'F':'O':'R':'M':'>':xs) = case takeNFORMs (pred n) xs of (b,r) -> (b, "" ++ r) +takeNFORMs n (x:xs) = case takeNFORMs n xs of (b,r) -> (b, x : r) + +dropNFORMs 0 xs = xs +dropNFORMs n "" = "" +dropNFORMs n ('<':'/':'F':'O':'R':'M':'>':xs) = dropNFORMs (pred n) xs +dropNFORMs n (x:xs) = dropNFORMs n xs + +synthesize :: Config -> String -> IO String +synthesize config predicate = do + handle <- connectTo (hostname config) (portID config) + hSetBuffering handle LineBuffering + hPutStrLn handle predicate + hGetContents handle + +-- just for testing and debugging +simpleCgiMain config + = do -- firstlines <- liftIO $ readFile "firstlines" + setHeader "Content-type" "text/html; charset=EUC-JP" + mbPred <- getInput "predicate" + case mbPred of Just predicate -> do result <- liftIO $ synthesize config predicate + output $ firstlines config False predicate ++ unlines (take 3 $ lines result) ++ lastLines False + Nothing -> output $ firstlines config False examplePredicate ++ lastLines False + +readUrk :: Read a => String -> a +readUrk xs = case reads xs of [(v,ys)] | all isSpace ys -> v + _ -> error $ "urk" ++ xs +\end{code} diff --git a/MagicHaskeller/ClassLib.lhs b/MagicHaskeller/ClassLib.lhs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/ClassLib.lhs @@ -0,0 +1,104 @@ +-- +-- (c) Susumu Katayama +-- +\begin{code} +module MagicHaskeller.ClassLib(mkCL, ClassLib(..), mguPrograms) where + +import MagicHaskeller.Types +import MagicHaskeller.TyConLib +import Control.Monad +import Data.Monoid +import MagicHaskeller.CoreLang +import Control.Monad.Search.Combinatorial +import MagicHaskeller.PriorSubsts +import Data.List(partition, sortBy, genericLength) +import Data.Ix(inRange) + +import MagicHaskeller.ProgramGenerator + +import MagicHaskeller.Classify +import MagicHaskeller.Instantiate + +import MagicHaskeller.Expression + +import MagicHaskeller.T10 + +import MagicHaskeller.DebMT + +traceTy _ = id +-- traceTy fty = trace ("lookup "++ show fty) + + +type BF = Recomp +-- type BF = DBound + +type BFM = Matrix +-- type BFM = DBMemo +fromMemo :: Search m => Matrix a -> m a +fromMemo = fromMx +toMemo :: Search m => m a -> Matrix a +toMemo = toMx + + +newtype ClassLib e = CL (MemoDeb e) + +type MemoTrie a = MapType (BFM (Possibility a)) + +lmt mt fty = + traceTy fty $ + lookupMT mt fty + +lookupFunsPoly :: (Search m, Expression e) => Generator m e -> Generator m e +lookupFunsPoly behalf memodeb@(mt,_,cmn) reqret + = PS (\subst mx -> + let (tn, decoder) = encode reqret mx + in -- ifDepth (<= memodepth (opt cmn)) + (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ fromMemo $ lmt mt tn) + -- (unPS (behalf memodeb reqret) subst mx) + ) + -- ¾ò·ï¤Ë¤è¤Ã¤ÆºÆ·×»»¤·¤¿¤¤¤È¤­¤Ïuncomment¤¹¤Ù¤·¡£¥á¥â¤ê¤Ï¿©¤ï¤Ê¤¤¤Ï¤º¤Ê¤Î¤Ç¡¢¾ï¤Ëmemoize¤ÇÌäÂê¤Ê¤¤¤Ï¤º¡£ + +type MemoDeb a = (MemoTrie a, [[Prim]], Common) + +mkCL :: Expression e => Common -> [Typed [CoreExpr]] -> ClassLib e +mkCL cmn classes = CL $ mkTrieMD [map annotateTCEs classes] cmn +mkTrieMD :: (Expression e) => [[Prim]] -> Common -> MemoDeb e +mkTrieMD qtl cmn + = let trie = mkMT (tcl cmn) (\ty -> fromRc (freezePS ty (mguFuns memoDeb ty))) + memoDeb = (trie,qtl,cmn) + in memoDeb + +-- moved from DebMT.lhs to avoid cyclic modules. +freezePS :: (Search m, Expression e) => Type -> PriorSubsts m (Bag e) -> m (Possibility e) +freezePS ty ps + = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) + in mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ fps mxty ps +fps :: (Search m, Expression e) => TyVar -> PriorSubsts m [e] -> m ([e],[(TyVar, Type)],TyVar) +fps mxty (PS f) = do + (es, sub, m) <- f emptySubst (mxty+1) + guard $ not $ length es `seq` null es + return (es, filterSubst sub mxty, m) + where filterSubst :: Subst -> TyVar -> [(TyVar, Type)] + filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. + + +type Generator m e = MemoDeb e -> Type -> PriorSubsts m [e] + + +mguPrograms, mguFuns :: (Search m, Expression e) => Generator m e +mguPrograms memodeb ty = do subst <- getSubst + lookupFunsPoly mguFuns memodeb (apply subst ty) +mguFuns memodeb = generateFuns mguPrograms memodeb + +-- MemoDeb¤Î·¿¤¬°ã¤¦¤È»È¤¨¤Ê¤¤¡¥ +generateFuns :: (Search m, Expression e) => + Generator m e -- ^ recursive call + -> Generator m e +generateFuns rec memodeb@(_mt, primmono,cmn) reqret + = let clbehalf = error "generateFuns: cannot happen." + behalf = rec memodeb + lltbehalf = error "generateFuns: cannot happen." + lenavails = 0 + in mapSum (retPrimMono cmn lenavails clbehalf lltbehalf behalf mguPS reqret) primmono + +\end{code} diff --git a/MagicHaskeller/Classification.hs b/MagicHaskeller/Classification.hs --- a/MagicHaskeller/Classification.hs +++ b/MagicHaskeller/Classification.hs @@ -1,18 +1,19 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS_GHC -cpp -XFlexibleInstances #-} -{-# LANGUAGE UndecidableInstances, OverlappingInstances, TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances, OverlappingInstances, TemplateHaskell, CPP, FlexibleInstances #-} -- x #define TESTEQ --- DBound$B$O$$$$$N!)(B - module MagicHaskeller.Classification -- ( -- randomTestFilter, -- :: Filtrable a => (b->a) -> Matrix b -> Matrix b -- ) where import Prelude hiding ((/)) +#ifdef TFRANDOM +import System.Random.TF.Gen +#else import System.Random +#endif import MagicHaskeller.MyCheck import Data.Char import Data.List @@ -23,11 +24,12 @@ import MagicHaskeller.MHTH import MagicHaskeller.TimeOut import MagicHaskeller.T10 -import MagicHaskeller.Classify(diffSortedBy, diffSortedByBot) +import MagicHaskeller.Instantiate(compareRealFloat) + class (Search m) => SStrategy m where sfilter :: Relation r => - (k->k->r) -> m ([k],e) -> m ([k],e) + (k->k->r) -> (Int->Int) -> m ([k],e) -> m ([k],e) ofilter :: Relation r => (k->k->r) -> m (k,e) -> m (k,e) @@ -39,12 +41,21 @@ sfilter = sfilterDB ofilter = ofilterDB +#ifdef TFRANDOM arbitraries :: Arbitrary a => [a] +arbitraries = arbs 0 (seedTFGen (12279932681387497184,218462391894233257,1625759680792809304,12756118543158863164)) +arbs :: Arbitrary a => Int -> TFGen -> [a] +arbs n stdgen = case map (splitn stdgen 8) [0..255] of + g0:gs -> zipWith f [n..] gs ++ arbs (n+255) g0 -- I think 255 seeds is enough, but just in case. + where Gen f = arbitrary +#else +arbitraries :: Arbitrary a => [a] arbitraries = arbs 0 (mkStdGen 1) arbs :: Arbitrary a => Int -> StdGen -> [a] arbs n stdgen = case split stdgen of (g0,g1) -> f n g0 : arbs (n+1) g1 where Gen f = arbitrary +#endif (/~) :: [a] -> (a->a->Bool) -> [[a]] [] /~ eq = [] @@ -153,47 +164,52 @@ cEQ = Just EQ randomTestFilter :: (SStrategy m, Filtrable a) => - m (e,a) -> m (e,a) -randomTestFilter = filt . fmap (\ t@(_,a) -> (a,t)) + (Int->Int) -> m (e,a) -> m (e,a) +randomTestFilter numRandoms = filt numRandoms . fmap (\ t@(_,a) -> (a,t)) unsafeRandomTestFilter :: (SStrategy m, Filtrable a) => Maybe Int -- ^ microsecs until timeout - -> m (e,a) -> m (e,a) -unsafeRandomTestFilter mto = unsafeFilt mto . fmap (\ t@(_,a) -> (a,t)) + -> (Int->Int) -> m (e,a) -> m (e,a) +unsafeRandomTestFilter mto numRandoms = unsafeFilt mto numRandoms . fmap (\ t@(_,a) -> (a,t)) mapFst f (a,b) = (f a, b) class Filtrable a where - filt :: SStrategy m => m (a,e) -> m e + filt :: SStrategy m => (Int->Int) -> m (a,e) -> m e filtFun :: (SStrategy m, Arbitrary b) => - m (b->a,e) -> m e + (Int->Int) -> m (b->a,e) -> m e unsafeFilt :: SStrategy m => - Maybe Int ->m (a,e) -> m e + Maybe Int -> (Int->Int) -> m (a,e) -> m e unsafeFiltFun :: (SStrategy m, Arbitrary b) => - Maybe Int -> m (b->a,e) -> m e + Maybe Int -> (Int->Int) -> m (b->a,e) -> m e instance (Arbitrary a, Filtrable r) => Filtrable (a->r) where - filt = filtFun - filtFun = filt . fmap (mapFst uncurry) - unsafeFilt mto = unsafeFiltFun mto - unsafeFiltFun mto = unsafeFilt mto . fmap (mapFst uncurry) + filt = filtFun + filtFun f = filt f . fmap (mapFst uncurry) + unsafeFilt mto f = unsafeFiltFun mto f + unsafeFiltFun mto f = unsafeFilt mto f . fmap (mapFst uncurry) #ifdef TESTEQ instance Eq a => Filtrable a where - filt = filtNullary (==) - filtFun = filtUnary (==) + filt = filtNullary (==) + filtFun = filtUnary (==) #else instance Ord a => Filtrable a where - filt = filtNullary compare - filtFun = filtUnary compare + filt = filtNullary compare + filtFun = filtUnary compare unsafeFilt mto = filtNullary (unsafeOpWithPTO mto compare) unsafeFiltFun mto = filtUnary (unsafeOpWithPTO mto compare) +instance Filtrable Double where + filt = filtNullary compareRealFloat + filtFun = filtUnary compareRealFloat + unsafeFilt mto = filtNullary (unsafeOpWithPTO mto compareRealFloat) + unsafeFiltFun mto = filtUnary (unsafeOpWithPTO mto compareRealFloat) #endif filtNullary :: (SStrategy m, Relation r) => - (k->k->r) -> m (k,e) -> m e -filtNullary op = fmap snd . ofilter op -filtUnary op = fmap snd . sfilter op . + (k->k->r) -> (Int->Int) -> m (k,e) -> m e +filtNullary op _ = fmap snd . ofilter op +filtUnary op f = fmap snd . sfilter op f . fmap (mapFst (flip map arbitraries)) instance (RealFloat a, Ord a) => @@ -244,8 +260,9 @@ sfilterMx :: Relation r => (k->k->r) -> + (Int->Int) -> Matrix ([k],e) -> Matrix ([k],e) -sfilterMx rel = representatives (map (liftRelation rel) ns) +sfilterMx rel numRands = representatives (map (liftRelation rel . numRands) [0..]) liftRelation :: Relation r => (k->k->r) -> Int -> ([k],e) -> ([k],e) -> r @@ -259,10 +276,9 @@ sfilterDB :: Relation rel => (k->k->rel) -> + (Int->Int)-> DBound ([k],e) -> DBound ([k],e) -sfilterDB rel (DB f) = DB $ \n -> - fromListByDB (liftRelation rel (ns!!n)) - (f n) +sfilterDB rel numRands (DB f) = DB $ \n -> fromListByDB (liftRelation rel (numRands n)) (f n) cumulativeQuotients relations (Mx xss) = let yss:ysss = zipWith (/) xss relations diff --git a/MagicHaskeller/Classify.hs b/MagicHaskeller/Classify.hs --- a/MagicHaskeller/Classify.hs +++ b/MagicHaskeller/Classify.hs @@ -3,8 +3,8 @@ -- {-# LANGUAGE MagicHash, CPP #-} module MagicHaskeller.Classify(randomTestFilter, filterBF, filterRc, filterDB -- , filterDBPos - , ofilterDB, opreexecute, CmpBot, cmpBot -- used by ClassifyDM.hs - , diffSortedBy, diffSortedByBot, FiltrableBF + , ofilterDB, opreexecute, CmpBot, cmpBot, cmpBotIO -- used by ClassifyDM.hs + , FiltrableBF ) where #define CHTO import Control.Monad.Search.Combinatorial @@ -26,7 +26,7 @@ import Control.Concurrent(yield) import Data.IORef #endif -import MagicHaskeller.T10(mergesortWithBy, mergeWithBy, mergesortWithByBot, mergeWithByBot) +import MagicHaskeller.T10(mergesortWithBy, mergeWithBy, mergesortWithByBot, mergeWithByBot, diffSortedBy, diffSortedByBot) #ifdef DEBUG import Test.QuickCheck @@ -120,13 +120,13 @@ unscanlByList :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e) -unscanlByList op mx = case unMx mx of yss@(xs:xss) -> Mx (xs : zipWith3 (deleteListByList op) tcnrnds xss yss) +unscanlByList op mx = case unMx mx of yss@(xs:xss) -> Mx (xs : zipWith3 (deleteListByList op) (tcnrnds op) xss yss) unscanlByListMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e) -unscanlByListMx op mx = zipDepth3Mx (\dep -> deleteListByList op (fcnrnd (1+dep))) mx (delay mx) +unscanlByListMx op mx = zipDepth3Mx (\dep -> deleteListByList op (fcnrnd op (1+dep))) mx (delay mx) unscanlByListRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e) -unscanlByListRc op rc = zipDepth3Rc (\dep -> deleteListByList op (fcnrnd (1+dep))) rc (delay rc) +unscanlByListRc op rc = zipDepth3Rc (\dep -> deleteListByList op (fcnrnd op (1+dep))) rc (delay rc) deleteListByList cmp len xs ys = dlbBot (liftCompareBot len cmp) xs ys @@ -165,9 +165,11 @@ c -} cmpBot (cmp,pto) x y = unsafeWithPTOOpt pto $ cmp x y +cmpBotIO (cmp,pto) x y = maybeWithTOOpt pto $ return $! cmp x y #else liftCmpBot len (cmp,_pto) xs ys = Just $ liftCmp len cmp xs ys cmpBot (cmp,_pto) x y = Just $ cmp x y +cmpBotIO (cmp,pto) x y = return $ Just $ cmp x y #endif -- dlb = deleteListBy @@ -177,21 +179,7 @@ dlbBot cmps xs ys = diffSortedByBot cmps (mergesortWithByBot undefined cmps xs) (mergesortWithByBot undefined cmps ys) dlb cmps xs ys = diffSortedBy cmps (mergesortWithBy undefined cmps xs) (mergesortWithBy undefined cmps ys) -} -diffSortedBy _ [] _ = [] -diffSortedBy _ vs [] = vs -diffSortedBy op vs@(c:cs) ws@(d:ds) = case op c d of EQ -> diffSortedBy op cs ds - LT -> c : diffSortedBy op cs ws - GT -> diffSortedBy op vs ds -diffSortedByBot _ [] _ = [] -diffSortedByBot _ vs [] = vs -diffSortedByBot op vs@(c:cs) ws@(d:ds) = case op c d of - Just EQ -> diffSortedByBot op cs ds - Just LT -> c : diffSortedByBot op cs ws - Just GT -> diffSortedByBot op vs ds --- Nothing -> c : diffSortedByBot op cs ds -- I just do not know what is the best solution here, but when timeout happens, I temporarily believe @c@, and skip d. - Nothing -> diffSortedByBot op cs ds -- The above turned out to be not a good solution, because when an error (or a timeout) happens, the expression repeatedly appears at each depth. See newnotes on Dec. 18, 2011 - {- repEqClsBy_simple :: (k->k->Ordering) -> Matrix ([k],e) -> Matrix ([k],e) repEqClsBy_simple cmp (Mx xss) = Mx $ zipWith (\dep ys -> mergesortWithByBot const (liftCompareBot dep cmp) $ filterEligibles dep ys) cnrnds $ scanl1_recompute (++) xss @@ -200,16 +188,16 @@ -} repEqClsBy_simple :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e) -repEqClsBy_simple cmp mx = Mx $ zipWith (\dep ys -> mergesortWithByBot const (liftCompareBot dep cmp) ys) cnrnds $ unMx $ scanl1BF mx +repEqClsBy_simple cmp mx = Mx $ zipWith (\dep ys -> mergesortWithByBot const (liftCompareBot dep cmp) ys) (cnrnds cmp) $ unMx $ scanl1BF mx repEqClsByMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e) -repEqClsByMx cmp mx = zipDepthMx (\dep ys -> let n = fcnrnd dep in mergesortWithByBot const (liftCompareBot n cmp) ys) $ scanl1BF mx +repEqClsByMx cmp mx = zipDepthMx (\dep ys -> let n = fcnrnd cmp dep in mergesortWithByBot const (liftCompareBot n cmp) ys) $ scanl1BF mx repEqClsByRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e) -repEqClsByRc cmp mx = zipDepthRc (\dep ys -> let n = fcnrnd dep in mergesortWithByBot const (liftCompareBot n cmp) ys) $ scanl1BF mx +repEqClsByRc cmp mx = zipDepthRc (\dep ys -> let n = fcnrnd cmp dep in mergesortWithByBot const (liftCompareBot n cmp) ys) $ scanl1BF mx eqClsBy_naive :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)] -eqClsBy_naive cmp (Mx xss) = Mx $ zipWith (\dep ys -> ys /// liftCompareBot dep cmp) cnrnds $ scanl1 (++) xss +eqClsBy_naive cmp (Mx xss) = Mx $ zipWith (\dep ys -> ys /// liftCompareBot dep cmp) (cnrnds cmp) $ scanl1 (++) xss {- ¿¾¯¸úΨ²½¤·¤è¤¦¤«¤È¤â»×¤Ã¤¿¤±¤É¡¤¤È¤ê¤¢¤¨¤º¤ÏËÜÅö¤Ënaive¤Ë¤ä¤ë eqClsBy_naive cmp mx = scanl (mergeBy cmp) (eqClsByFstNs cmp mx) @@ -222,10 +210,9 @@ ncmp = 5 fcnrnd = (1+ncmp+) -} -fcnrnd n | n <= 5 = 5 - | otherwise = n+1 -cnrnds = map fcnrnd [0..] -tcnrnds = tail cnrnds +fcnrnd (_,opt) = fcnrand opt +cnrnds tup = map (fcnrnd tup) [0..] +tcnrnds tup = map (fcnrnd tup) [1..] -- repEqClsBy cmp = [([k]¤ÎºÇ½é¤Î1¸Ä¤Î¤ß¤ò¸«¤¿¤È¤­¤ÎƱÃÍÎàʬ²ò¤ÎÂåɽ¸µ¤¿¤Á), ([k]¤ÎºÇ½é¤Î2¸Ä¤Î¤ß¤ò¸«¤¿¤È¤­¤ÎƱÃÍÎàʬ²ò¤ÎÂåɽ¸µ¤¿¤Á), ([k]¤ÎºÇ½é¤Î3¸Ä¤Î¤ß¤ò¸«¤¿¤È¤­¤ÎƱÃÍÎàʬ²ò¤ÎÂåɽ¸µ¤¿¤Á), ....] repEqClsBy :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e) @@ -234,8 +221,8 @@ -- eqClsBy¤Î·ë²Ì¤Î¿¼¤µnÈÖÌܤˤϡ¤[k]¤ÎºÇ½é¤În¸Ä¤òcmp¤ÇÈæ³Ó¤·¤¿¤È¤­¤ÎƱÃÍ´Ø·¸¤Ë¤è¤ëƱÃÍÎàʬ²ò¤¬Æþ¤Ã¤Æ¤¤¤ë¡¥ -- x ¿¼¤µ1¤Ç¥µ¥¤¥º1¤Ê¤ä¤Ä¤é¤òƱÃÍÎàʬ²ò : ¿¼¤µ1¤Ç¤Îʬ²ò·ë²Ì¤ò2ʸ»úÌܤÇƱÃÍÎàʬ²ò¤·¤¿¥ä¥Ä¤È¡¤¥µ¥¤¥º2¤Î¤ä¤Ä¤é¤ò2ʸ»úʬ¸«¤ÆƱÃÍÎàʬ²ò¤·¤¿¤ä¤Ä¤é¤ò¥Þ¡¼¥¸ : ¿¼¤µ2¤Ç¤Îʬ²ò·ë²Ì¤ò3ʸ»úÌܤÇƱÃÍÎàʬ²ò¤·¤¿Åۤȡ¤.... eqClsBy :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)] -eqClsBy cb@(cmp,_) mx = Mx $ - scanl (\xs (n,ys) -> mergeBy (liftCompareBot n cb) (eqClsByNth cmp n xs) ys) ecb0 $ zip tcnrnds ecbs +eqClsBy cb@(cmp,opt) mx = Mx $ + scanl (\xs (n,ys) -> mergeBy (liftCompareBot n cb) (eqClsByNth cmp n xs) ys) ecb0 $ zip (tcnrnds cb) ecbs {- scanl¤Î1¹Ô¤ÎÂå¤ï¤ê¤Ë¤³¤Ã¤Á¤ò»È¤Ã¤Æ¤¿¡¥ let result = ecb0 : zipWith3 (\n xs ys -> mergeBy (liftCompareBot n cmp) (eqClsByNth n xs) ys) (tail cnrnds) result ecbs in result @@ -246,7 +233,7 @@ eqClsByNth cmp n = concatMap ((/// (\ (xs,_) (ys,_) -> Just $ cmp (xs!!(n-1)) (ys!!(n-1))))) eqClsByFstNs :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)] -eqClsByFstNs cmp (Mx tss) = Mx $ zipWith eqClsByFstN cnrnds tss +eqClsByFstNs cmp (Mx tss) = Mx $ zipWith eqClsByFstN (cnrnds cmp) tss where eqClsByFstN n = (/// liftCompareBot n cmp) isLongEnough 0 _ = True @@ -277,7 +264,7 @@ -} sfilterDB :: CmpBot k -> DBound ([k],e) -> DBound ([k],e) -sfilterDB cmp (DB f) = DB $ \n -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i liftCompareBot (fcnrnd n) cmp k l) (f n) +sfilterDB cmp (DB f) = DB $ \n -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i liftCompareBot (fcnrnd cmp n) cmp k l) (f n) ofilterDB :: CmpBot k -> DBound (k,e) -> DBound (k,e) ofilterDB cmp (DB f) = DB $ \n -> mergesortWithByBot const (\((k,_),_) ((l,_),_) -> cmpBot cmp k l) (f n) diff --git a/MagicHaskeller/ClassifyDM.hs b/MagicHaskeller/ClassifyDM.hs --- a/MagicHaskeller/ClassifyDM.hs +++ b/MagicHaskeller/ClassifyDM.hs @@ -3,7 +3,7 @@ -- {-# LANGUAGE CPP #-} #define CHTO -module MagicHaskeller.ClassifyDM(filterDM, filterList, filterListDB, filterDMlite, spreexecuteDM) where -- , filterDMTI) where +module MagicHaskeller.ClassifyDM(filterDM, filterList, filterListDB, filterDMIO, spreexecuteDM) where -- , filterDMTI) where import Control.Monad.Search.Combinatorial import Data.Maybe @@ -18,15 +18,20 @@ import MagicHaskeller.TimeOut import Data.IORef #endif -import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot) +import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot, mergesortWithByBotIO) import MagicHaskeller.PriorSubsts -import MagicHaskeller.Classify(opreexecute, ofilterDB, CmpBot, cmpBot) -- ofilterDB ¤Ï¤³¤Ã¤Á¤ÇÄêµÁ¤µ¤ì¤Æ¤¤¤Æ¤â¤¤¤¤¤è¤¦¤Ê¤â¤Î¡¥ +import MagicHaskeller.Classify(opreexecute, ofilterDB, CmpBot, cmpBot, cmpBotIO) -- ofilterDB ¤Ï¤³¤Ã¤Á¤ÇÄêµÁ¤µ¤ì¤Æ¤¤¤Æ¤â¤¤¤¤¤è¤¦¤Ê¤â¤Î¡¥ import MagicHaskeller.Expression import MagicHaskeller.ProgramGenerator(Common(..)) import MagicHaskeller.Options(Opt(..)) +-- import Data.MapByBot + +-- sortWithByBot f cmp = Data.MapByBot.elems . Data.MapByBot.fromListWith cmp (flip f) . map (\k -> (k,k)) +sortWithByBot = mergesortWithByBot + select :: DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr) -- select (DB f) = DB $ \n -> map (\((xss,ae),i) -> (((xss!!n), ae),i)) $ f n select = zipDepthDB $ \d -> map (\((xss,ae),i) -> (((xss!!d), ae),i)) @@ -47,10 +52,10 @@ = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of Nothing -> id Just ([], op) -> -- fmap snd . ofilterDB op . fmap opreexecute - mergesortWithByBot const (\(AE _ k) (AE _ l) -> cmpBot (op, opt cmn) k l) + sortWithByBot const (\(AE _ k) (AE _ l) -> cmpBot (op, opt cmn) k l) Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss) map snd . - mergesortWithByBot const + sortWithByBot const (nthCompareBot (nrands $ opt cmn) db (op, opt cmn)) . map (\ae -> sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae db) filterListDB :: Common -> Type -> [AnnExpr] -> DBound [AnnExpr] @@ -62,12 +67,25 @@ = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of Nothing -> id Just ([], op) -> -- fmap snd . ofilterDB op . fmap opreexecute - mapDepthDB $ mergesortWithByBot const (\((AE _ k),_) ((AE _ l),_) -> cmpBot (op, opt cmn) k l) + mapDepthDB $ sortWithByBot const (\((AE _ k),_) ((AE _ l),_) -> cmpBot (op, opt cmn) k l) Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss) zipDepthDB (\d -> map (\((_dyns,ae),i) -> (ae,i)) . - mergesortWithByBot (\x@(_,i) y@(_,j) -> if i if i nthCompareBot (nrands $ opt cmn) d (op, opt cmn) k l) . map (\(ae,i) -> (sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae d, i))) + +filterDMIO :: Common -> Type -> DBound AnnExpr -> DBoundT IO AnnExpr +filterDMIO cmn typ db + = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of + Nothing -> fromDB db + Just ([], op) -> -- fmap snd . ofilterDB op . fmap opreexecute + DBT $ \d -> mergesortWithByBotIO const (\((AE _ k),_) ((AE _ l),_) -> cmpBotIO (op, opt cmn) k l) $ unDB db d + Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss) + DBT $ \d -> fmap (map (\ ((_dyns,ae),i) -> (ae,i))) $ + mergesortWithByBotIO (\x@(_,i) y@(_,j) -> if i nthCompareBotIO (nrands $ opt cmn) d (op, opt cmn) k l) + (map (\(ae,i) -> (sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae d, i)) $ unDB db d) + -- depth bound(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ë°ú¿ô¤ÎInt)¤ÎÂå¤ï¤ê¤Ë¡¤depth bound¤«¤é¤Îµ÷Î¥(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ëInt->[(a,¤³¤³¤ÎInt)])¤ò»È¤Ã¤Ænrnds¤Î²¿ÈÖÌܤ«¤ò·è¤á¤ë¤â¤Î¡¥ -- filterDM¤È°ã¤Ã¤Æ¡¤Æ±¤¸depth bound¤Ç¤â°ã¤¦Íð¿ô¤ò»È¤¦¤Î¤Ç¡¤filterListƱÍÍdepth¤ò¸Ù¤¤¤Àfiltration¤¬¤Ç¤­¤º¡¤·ë²Ì¤Ï¤¤¤Þ¤¤¤Á¡¥ -- ¤¿¤À¤·¡¤dynamic¤Ê´Ø¿ô¼«ÂΤò¥á¥â²½¤¹¤ì¤Ð¡¤³ÊÃʤ˥á¥â¤Ë¥Ò¥Ã¥È¤·¤ä¤¹¤¯¤Ê¤ë¤Ï¤º¡¥ @@ -76,7 +94,7 @@ = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of Nothing -> id Just ([], op) -> -- fmap snd . ofilterDB op . fmap opreexecute - mapDepthDB $ mergesortWithByBot const (\((AE _ k),_) ((AE _ l),_) -> cmpBot (op, opt cmn) k l) + mapDepthDB $ sortWithByBot const (\((AE _ k),_) ((AE _ l),_) -> cmpBot (op, opt cmn) k l) Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss) zipDepthDB (\d -> map (\((_dyns,ae),i) -> (ae,i)) . shrink const (\k l -> nthCompareBot (nrands $ opt cmn) d (op, opt cmn) k l) d . @@ -97,10 +115,19 @@ listCmpBot len (cmp,_) xs ys = Just $ listCmp len cmp xs ys #endif +nthCompareBotIO :: [Int] -> Int -> CmpBot a -> ([a],e) -> ([a],e) -> IO (Maybe Ordering) +nthCompareBotIO nrnds m cmp (xs,_) (ys,_) = listCmpBotIO (nrnds !! m) cmp xs ys +listCmpBotIO :: Int -> CmpBot a -> [a] -> [a] -> IO (Maybe Ordering) +#ifdef CHTO +listCmpBotIO len (cmp,pto) xs ys = maybeWithTOOpt pto $ return $! listCmp len cmp xs ys +#else +listCmpBotIO len (cmp,_) xs ys = return $ Just $ listCmp len cmp xs ys +#endif + sfilterDM :: [Int] -> CmpBot k -> DBound ([k],e) -> DBound ([k],e) --- sfilterDM nrnds cmp (DB f) = DB $ \n -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i nthCompareBot nrnds n cmp k l) (f n) -sfilterDM nrnds cmp = zipDepthDB $ \d -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i nthCompareBot nrnds d cmp k l) +-- sfilterDM nrnds cmp (DB f) = DB $ \n -> sortWithByBot (\x@(_,i) y@(_,j) -> if i nthCompareBot nrnds n cmp k l) (f n) +sfilterDM nrnds cmp = zipDepthDB $ \d -> sortWithByBot (\x@(_,i) y@(_,j) -> if i nthCompareBot nrnds d cmp k l) {- uniqDM :: (k->k->Ordering) -> DBound ([[k]],e) -> DBound ([[k]],e) uniqDM cmp (DB f) = DB $ \n -> uniqByBot (\x@(_,i) y@(_,j) -> if i nthCompareBot n cmp k l) (f n) @@ -123,6 +150,6 @@ ofilterDBTI cmp (DBT f) = DBT $ \n -> fmap (mergesortWithBy (\x@(_,i) y@(_,j) -> if i cmp k l)) (f n) sfilterDMTI :: (k->k->Ordering) -> DBoundT (PriorSubsts []) ([[k]],e) -> DBoundT (PriorSubsts []) ([[k]],e) -sfilterDMTI cmp (DBT f) = DBT $ \n -> fmap (mergesortWithByBot (\x@(_,i) y@(_,j) -> if i nthCompareBot n cmp k l)) +sfilterDMTI cmp (DBT f) = DBT $ \n -> fmap (sortWithByBot (\x@(_,i) y@(_,j) -> if i nthCompareBot n cmp k l)) (f n) -} diff --git a/MagicHaskeller/CoreLang.lhs b/MagicHaskeller/CoreLang.lhs --- a/MagicHaskeller/CoreLang.lhs +++ b/MagicHaskeller/CoreLang.lhs @@ -22,7 +22,7 @@ import qualified MagicHaskeller.PolyDynamic as PD -- import MagicHaskeller.MyDynamic -import Data.Char(chr,ord) +import Data.Char(chr,ord,isDigit) import MagicHaskeller.TyConLib import MagicHaskeller.ReadTHType(thTypeToType) #ifdef FORCE @@ -31,39 +31,67 @@ -- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out. import Data.Bits -import Data.HashTable(hashInt, prime) import Data.Function(fix) +import Data.Int +import Data.Word +import Data.List(genericLength, genericIndex) + infixl :$ +type Var = Int16 data CoreExpr = S | K | I | B | C | S' | B' | C' | Y - | Lambda CoreExpr | X Int -- de Bruijn notation + | Lambda CoreExpr | X {-# UNPACK #-} !Int8 -- de Bruijn notation +-- | Lambda CoreExpr | X Int8 -- de Bruijn notation | FunLambda CoreExpr | FunX Int -- different system of de Bruijn notation for functions, used by IOPairs.hs - | Tuple Int + | Tuple {-# UNPACK #-} !Int8 +-- | Tuple Int8 +{- | Primitive Int Bool -- True if the primitive is a constructor expression +-} + | Primitive {primId :: {-# UNPACK #-} !Var} -- (This should be Var instead of Int8 because the number space is being exhausted!) + | PrimCon {primId :: {-# UNPACK #-} !Var} -- the primitive is a constructor expression +-- | Primitive {primId :: Var} -- (This should be Var instead of Int8 because the number space is being exhausted!) +-- | PrimCon {primId :: Var} -- the primitive is a constructor expression + | Context Dictionary | CoreExpr :$ CoreExpr - | Case CoreExpr [(Int,Int,CoreExpr)] -- the case expression. [(primitive ID of the constructor, arity of the constructor, rhs of ->)] - | Fix CoreExpr Int [Int] -- Fix expr n is === foldl (:$) (Y :$ FunLambda (napply n Lambda expr)) (map X is) + | Case CoreExpr [(Var,Int8,CoreExpr)] -- the case expression. [(primitive ID of the constructor, arity of the constructor, rhs of ->)] + | Fix CoreExpr Int8 [Int8] -- Fix expr n is === foldl (:$) (Y :$ FunLambda (napply n Lambda expr)) (map X is) {- | FixCase [(Int,Int,CoreExpr)] -- FixCase ts === (Y :$ Lambda (Lambda (Case (X 0) ts))) -- See notes on July 3, 2010 -} | VarName String -- This is only used for pretty printing IOPairs.Expr. Use de Bruijn variables for other purposes. - deriving (Read, Eq, Show, Ord) + deriving (Eq, Show, Ord) +newtype Dictionary = Dict {undict :: PD.Dynamic} deriving (Show) +instance Ord Dictionary where + compare _ _ = EQ -- This should work for the current purposes, but can cause a bug. +instance Eq Dictionary where + _ == _ = True -- This should work for the current purposes, but can cause a bug. + -- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out. #ifdef FORCE instance NFData CoreExpr where rnf (Lambda e) = rnf e rnf (X i) = rnf i rnf (Tuple i) = rnf i - rnf (Primitive _ _) = () -- ºÇ¸å¤Î¥Ñ¥¿¡¼¥ó¤Ë¥Þ¥Ã¥Á¤¹¤ë¤Î¤Ç¤³¤ì¤ÏÍפé¤Ê¤«¤Ã¤¿¤«¡¥ + rnf (Primitive _) = () -- ºÇ¸å¤Î¥Ñ¥¿¡¼¥ó¤Ë¥Þ¥Ã¥Á¤¹¤ë¤Î¤Ç¤³¤ì¤ÏÍפé¤Ê¤«¤Ã¤¿¤«¡¥ rnf (c :$ d) = rnf c `seq` rnf d rnf e = () #endif + +isAbsent :: Int -> CoreExpr -> Bool +isAbsent numArgs expr = isa (2^numArgs - 1) expr /= 0 +isa :: Integer -> CoreExpr -> Integer +isa bits (X n) = clearBit bits $ fromIntegral n +isa bits (Lambda e) = isa (bits `unsafeShiftL` 1) e `unsafeShiftR` 1 +isa bits (f :$ e ) = isa (isa bits f) e +isa bits Primitive{} = bits +isa bits Context{} = bits {- unused due to inefficiency ceToInteger (Lambda e) = ceToInteger e -- ·¿¤¬ÊѤï¤Ã¤Á¤ã¤¦¤Î¤ÇLambda¤Ï̵»ë¤Ç¤­¤ë¤Ï¤º¡¥... ¤È¤¤¤¤¤Ä¤Ä¼«¿®Ìµ¡¥July 24, 2008¤Înotes¤ò»²¾È. ¤Þ¡¤hash¤Ë¤Ï»È¤¨¤ë¤È¤¤¤¦ÄøÅ٤ΤĤâ¤ê¡¥ ceToInteger (f :$ e) = 3 * (ceToInteger f `interleave` ceToInteger e) @@ -76,13 +104,6 @@ logShiftR1 n = (n `clearBit` 0) `rotateR` 1 -} -instance Enum CoreExpr where - fromEnum (Lambda e) = fromIntegral prime * fromEnum e -- ·¿¤¬ÊѤï¤Ã¤Á¤ã¤¦¤Î¤ÇLambda¤Ï̵»ë¤Ç¤­¤ë¤Ï¤º¡¥... ¤È¤¤¤¤¤Ä¤Ä¼«¿®Ìµ¡¥July 24, 2008¤Înotes¤ò»²¾È. ¤Þ¡¤hash¤Ë¤Ï»È¤¨¤ë¤È¤¤¤¦ÄøÅ٤ΤĤâ¤ê¡¥ - fromEnum (f :$ e) = fromEnum f #* fromEnum e - fromEnum (X n) = n * 0xdeadbeef - fromEnum (Primitive n _) = (-1-n) * 0xdeadbeef -m #* c = fromIntegral (hashInt m) + (c `mod` fromIntegral prime) - instance Ord Exp where compare (VarE n0) (VarE n1) = n0 `compare` n1 compare (VarE n0) _ = LT @@ -100,18 +121,25 @@ readsPrec _ str = [(error "ReadS Exp is not implemented yet", str)] -type VarLib = Array Int PD.Dynamic +type VarLib = Array Var PD.Dynamic +actualVarName :: String -> Exp +actualVarName = VarE . mkName . stripByd_ +stripByd_ ('b':'y':d:'_':name) | isDigit d = name +stripByd_ ('-':'-':'#':name) = dropWhile (=='#') name +stripByd_ name = name + -- x Âè1°ú¿ô¤Îpl¤ÏArray Con String¤Ê¤ó¤À¤±¤É¡¤¤â¤¦Á´ÉôPrimitive¤ò»È¤¦¤³¤È¤Ë¤Ê¤Ã¤¿¤Î¤ÇÉÔÍס¥ -- exprToTHExp converts CoreLang.CoreExpr into Language.Haskell.TH.Exp exprToTHExp, exprToTHExpLite :: VarLib -> CoreExpr -> Exp exprToTHExp vl e = exprToTHExp' True vl $ lightBeta e exprToTHExpLite vl e = exprToTHExp' False vl $ lightBeta e -exprToTHExp' pretty vl e = x2hsx (ord 'a'-1) (ord 'a' -1) e - where x2hsx dep fdep (Lambda e) = +exprToTHExp' pretty vl e = x2hsx (fromIntegral $ ord 'a'-1 :: Int8) (ord 'a' -1) e + where x2hsx :: Int8 -> Int -> CoreExpr -> Exp + x2hsx dep fdep (Lambda e) = case x2hsx (dep+1) fdep e of LamE pvars expr -> LamE (pvar:pvars) expr expr -> LamE [pvar] expr - where var = mkName [chr (dep+1)] + where var = mkName [chr $ fromIntegral (dep+1)] pvar | not pretty || 0 `occursIn` e = VarP var | otherwise = WildP x2hsx dep fdep (FunLambda e) = @@ -120,27 +148,15 @@ where var = mkName ['f',chr (fdep+1)] pvar | not pretty || 0 `funOccursIn` e = VarP var | otherwise = WildP - x2hsx dep fdep (X n) = VarE (mkName [chr (dep - n)]) -- X n¤ÏX 0, X 1, .... - x2hsx dep fdep (FunX n) = VarE (mkName ['f',chr (fdep - n)]) -- X n¤ÏX 0, X 1, .... + x2hsx dep fdep (X n) = VarE (mkName [chr $ fromIntegral (dep - n :: Int8)]) -- X n¤ÏX 0, X 1, .... + x2hsx dep fdep (FunX n) = VarE (mkName ['f', chr $ fromIntegral (fdep - n)]) -- X n¤ÏX 0, X 1, .... -- x2hsx _ (Qualified con) = VarE (mkName (pl ! con)) - x2hsx _ _ (Primitive n _) = case PD.dynExp (vl ! n) of ConE name -> ConE $ mkName $ nameBase name - VarE name -> VarE $ mkName $ nameBase name - e -> e - x2hsx dep fdep (Primitive n _ :$ e0 :$ e1) - = let hsx0 = x2hsx dep fdep e0 - hsx1 = x2hsx dep fdep e1 - in case PD.dynExp (vl!n) of - e@(VarE name) | head (nameBase name) `elem` "!@#$%&*+./<=>?\\^|-~" - -> InfixE (Just hsx0) (VarE $ mkName $ nameBase name) (Just hsx1) - | otherwise -> (VarE (mkName $ nameBase name) `AppE` hsx0) `AppE` hsx1 - e@(ConE name) | namestr == ":" -> case hsx1 of ListE hsxs -> ListE (hsx0 : hsxs) - ConE n | nameBase n == "[]" -> ListE [hsx0] - _ -> InfixE (Just hsx0) (ConE $ mkName ":") (Just hsx1) - | head namestr == ':' -> InfixE (Just hsx0) (ConE $ mkName namestr) (Just hsx1) - | otherwise -> (ConE (mkName namestr) `AppE` hsx0) `AppE` hsx1 - where - namestr = nameBase name - e -> (e `AppE` hsx0) `AppE` hsx1 + x2hsx _ _ (Primitive n) = x2hsxPrim n + x2hsx _ _ (PrimCon n) = x2hsxPrim n + x2hsx dep fdep (p@(Primitive _) :$ e :$ e0 :$ e1) | hdIsCxt e = x2hsxPrim3 dep fdep p e0 e1 + x2hsx dep fdep (p@(PrimCon _) :$ e :$ e0 :$ e1) | hdIsCxt e = x2hsxPrim3 dep fdep p e0 e1 -- cannot happen currently, but maybe in future if negate and succ will become polymorphic and regarded as constructors. + x2hsx dep fdep (p@(Primitive _) :$ e0 :$ e1) = x2hsxPrim3 dep fdep p e0 e1 + x2hsx dep fdep (p@(PrimCon _) :$ e0 :$ e1) = x2hsxPrim3 dep fdep p e0 e1 x2hsx dep fdep (Y :$ FunLambda e) = case x2hsx dep fdep (FunLambda e) of LamE [WildP] expr -> expr LamE (WildP:pvs) expr -> LamE pvs expr expr -> VarE 'fix `AppE` expr @@ -148,11 +164,12 @@ x2hsx dep fdep (Y :$ Lambda e) = case x2hsx dep fdep (Lambda e) of LamE [WildP] expr -> expr LamE (WildP:pvs) expr -> LamE pvs expr expr -> VarE 'fix `AppE` expr - x2hsx dep fdep (e0 :$ e1) = x2hsx dep fdep e0 `AppE` x2hsx dep fdep e1 + x2hsx dep fdep (e0 :$ e1) | hdIsCxt e1 = x2hsx dep fdep e0 + | otherwise = x2hsx dep fdep e0 `AppE` x2hsx dep fdep e1 x2hsx dep fdep (Case ce ts) = CaseE (x2hsx dep fdep ce) (map (tsToMatch dep fdep) ts) -- x2hsx dep fdep (Fix ce n is) = x2hsx dep fdep $ foldl (:$) (Y :$ FunLambda (napply n Lambda ce)) (map X is) -- let¤ò»È¤Ã¤Æ½ñ¤¤¤¿Êý¤¬¤¤¤¤´¶¤¸¤Ë¤Ê¤ë¡¥ x2hsx dep fdep (Fix ce n is) - = case x2hsx dep fdep (FunLambda (napply n Lambda ce)) of + = case x2hsx dep fdep (FunLambda (napply (fromIntegral n) Lambda ce)) of LamE (WildP:ps) e -> foldl AppE (LamE ps e) $ map (x2hsx dep fdep . X) is @@ -172,33 +189,69 @@ -- x2hsx dep (FixCase ts) = x2hsx dep (Y :$ Lambda (Lambda (Case (X 0) ts))) x2hsx dep _ (VarName str) = VarE (mkName str) x2hsx _ _ Y = VarE 'fix - x2hsx _ _ e = error ("exprToTHExp: converting" ++ show e) + x2hsx _ _ K = VarE 'const + x2hsx _ _ B = VarE '(.) + x2hsx _ _ C = VarE 'flip + x2hsx _ _ S = VarE $ mkName "ap" + x2hsx _ _ I = VarE 'id + x2hsx _ _ S' = VarE $ mkName "sprime" + x2hsx _ _ B' = VarE $ mkName "bprime" + x2hsx _ _ C' = VarE $ mkName "cprime" + x2hsx _ _ e = error ("exprToTHExp: converting " ++ show e) + x2hsxPrim n = case PD.dynExp (vl ! n) of + ConE name -> ConE $ mkName $ nameBase name + VarE name -> actualVarName $ nameBase name + e -> e + x2hsxPrim3 dep fdep p e0 e1 + | hdIsCxt e0 = x2hsx dep fdep (p :$ e1) + | otherwise + = let hsx0 = x2hsx dep fdep e0 + hsx1 = x2hsx dep fdep e1 + n = primId p + in case PD.dynExp (vl!n) of + e@(VarE name) | head base `elem` "!@#$%&*+./<=>?\\^|-~" + -> InfixE (Just hsx0) (actualVarName base) (Just hsx1) + | otherwise -> (actualVarName base `AppE` hsx0) `AppE` hsx1 + where base = nameBase name + e@(ConE name) | namestr == ":" -> case hsx1 of ListE hsxs -> ListE (hsx0 : hsxs) + ConE n | nameBase n == "[]" -> ListE [hsx0] + _ -> InfixE (Just hsx0) (ConE $ mkName ":") (Just hsx1) + | head namestr == ':' -> InfixE (Just hsx0) (ConE $ mkName namestr) (Just hsx1) + | otherwise -> (ConE (mkName namestr) `AppE` hsx0) `AppE` hsx1 + where + namestr = nameBase name + e -> (e `AppE` hsx0) `AppE` hsx1 + + hdIsCxt (Context{}) = True + hdIsCxt (e :$ _) = hdIsCxt e + hdIsCxt _ = False replacePat name new (VarP o) | o==name = AsP name new replacePat _ _ old = old tsToMatch dep fdep (ctor, arity, expr) = case PD.dynExp (vl ! ctor) of - ConE name -> case x2hsx dep fdep (napply arity Lambda expr) of - LamE pvars ex -> case compare (length pvars) arity of + ConE name -> case x2hsx dep fdep (napply arint Lambda expr) of + LamE pvars ex -> case compare (length pvars) arint of LT -> error "too few lambda abstractions in Case...can't happen!" EQ -> Match (mkPat nameb pvars) (NormalB ex) [] GT -> Match (mkPat nameb tk) (NormalB $ LamE dr ex) [] - where (tk,dr) = splitAt arity pvars + where (tk,dr) = splitAt arint pvars ex -- -- | not pretty && nameb == "[]" -> Match (ConP '[] []) (NormalB ex) [] | otherwise -> Match (ConP (mkName nameb) []) (NormalB ex) [] where nameb = nameBase name + arint = fromIntegral arity mkPat ":" [pv1,pv2] = InfixP pv1 (mkName ":") pv2 mkPat (':':_) [pv1,pv2] = InfixP pv1 (mkName nameb) pv2 mkPat nmb pvs = ConP (mkName nameb) pvs VarE name | nameBase name == "succ" -> case x2hsx (dep+1) fdep expr of -- ¤³¤³¤Îcase¤ÏºÇ½éx2hsx dep $ Lambda expr¤Ë¤·¤Æ¤¤¤¿¤Î¤À¤¬¡¤WildP¤Ë¤Ê¤Ã¤Æ¤·¤Þ¤¦¤Èguard¤Ç¤­¤Ê¤¯¤Ê¤ë¤·¡¤¤«¤È¤¤¤Ã¤ÆCase¤ÎÆ⦤ÇWildP¤Ø¤ÎÃÖ´¹¤ò¤ä¤é¤Ê¤¤¤È¤¹¤ë¤È¤ß¤Ë¤¯¤¤¤·¡¤¤³¤Î¥Ñ¥¿¡¼¥ó¤À¤±WildP¤ò»ß¤á¤ë¤¯¤é¤¤¤Ê¤éLambda¤Îʬ¤òŸ³«¤·¤¿Êý¤¬Áᤤ¤ä¡¤¤Ã¤Æ¤³¤È¤Ç¡¥ ex -> Match (VarP succn) (GuardedB [(NormalG (InfixE (Just $ VarE succn) (VarE $ mkName ">") (Just $ LitE $ IntegerL 0)),ex)]) [ValD (VarP name) (NormalB (InfixE (Just $ VarE succn) (VarE $ mkName "-") (Just $ LitE (IntegerL 1)))) []] - where str = [chr (dep+1)] + where str = [chr $ fromIntegral (dep+1)] name = mkName str succn = mkName ("succ"++str) | nameBase name == "negate" -> case x2hsx (dep+1) fdep expr of ex -> Match (VarP negn) (GuardedB [(NormalG (InfixE (Just $ VarE negn) (VarE $ mkName "<") (Just $ LitE $ IntegerL 0)),ex)]) [ValD (VarP name) (NormalB ((VarE 'negate) `AppE` (VarE negn))) []] - where str = [chr (dep+1)] + where str = [chr $ fromIntegral (dep+1)] name = mkName str negn = mkName ("neg"++str) LitE lit -> Match (LitP lit) (NormalB $ x2hsx dep fdep expr) [] @@ -246,6 +299,7 @@ liftFun th (Case x ts) = Case (liftFun th x) (map (\(c,a,ce) -> (c,a,liftFun th ce)) ts) liftFun th (Fix e m is) = Fix (liftFun (succ th) e) m is liftFun _ e = e +nlift :: Int8 -> Int8 -> CoreExpr -> CoreExpr nlift th n (X i) | th (c,a,nlift (th+a) n ce)) ts) nlift th n (Fix e m is) = Fix (nlift (th+m) n e) m (map (nliftInt th n) is) nlift th n e = e +nliftInt :: Int8 -> Int8 -> Int8 -> Int8 nliftInt th n i | th < i = i-n | otherwise = i -napply n f x = iterate f x !! n +napply n f x = iterate f x `genericIndex` n @@ -287,14 +342,14 @@ primitivesToVL :: TyConLib -> [Primitive] -> VarLib primitivesToVL tcl ps - = listArray (0, length ps + (lenDefaultPrimitives-1)) (map (\ (HV x, e, ty) -> PD.unsafeToDyn tcl (thTypeToType tcl ty) x e) ps + = listArray (0, genericLength ps + (lenDefaultPrimitives-1)) (map (\ (HV x, e, ty) -> PD.unsafeToDyn tcl (thTypeToType tcl ty) x e) ps ++ defaultPrimitives) -- | 'defaultVarLib' can be used as a VarLib for testing and debugging. Currently this is used only by the analytical synthesizer. defaultVarLib :: VarLib defaultVarLib = listArray (0, lenDefaultPrimitives-1) defaultPrimitives -lenDefaultPrimitives = length defaultPrimitives +lenDefaultPrimitives = genericLength defaultPrimitives -- | @defaultPrimitives@ is the set of primitives that we want to make sure to appear in VarLib but may not appear in the primitive set with which to synthesize. -- In other words, it is the set of primitives we want to make sure to assign IDs to. diff --git a/MagicHaskeller/DebMT.lhs b/MagicHaskeller/DebMT.lhs --- a/MagicHaskeller/DebMT.lhs +++ b/MagicHaskeller/DebMT.lhs @@ -15,9 +15,12 @@ import MagicHaskeller.T10((!?)) +import Data.List(genericIndex) +import System.IO.Unsafe(unsafeInterleaveIO) + -- type MemoTrie = MapType (Matrix Possibility) -type Possibility e = (Bag e, Subst, Int) +type Possibility e = (Bag e, Subst, TyVar) data MapType a = MT { tvMT :: [a], @@ -29,9 +32,9 @@ lookupMT :: MapType a -> Type -> a -- lookupMT :: MonadPlus m => MapType (m a) -> Type -> (m a) -lookupMT mt (TV tv) = tvMT mt !! tv -lookupMT mt (TC tc) | tc < 0 = genMT mt !! (-1-tc) - | otherwise = tcMT mt !! tc +lookupMT mt (TV tv) = tvMT mt `genericIndex` tv +lookupMT mt (TC tc) | tc < 0 = genMT mt `genericIndex` (-1-tc) + | otherwise = tcMT mt `genericIndex` tc lookupMT mt (TA t0 t1) = lookupMT (lookupMT (taMT mt) t0) t1 lookupMT mt (t0:->t1) = lookupMT (lookupMT (funMT mt) t0) t1 @@ -45,7 +48,7 @@ decodeVar (Dec tvs margin) tv = case tvs !? tv of Nothing -> tv+margin Just ntv -> ntv -encode :: Type -> Int -> (Type, Decoder) +encode :: Type -> TyVar -> (Type, Decoder) encode = Types.normalizeVarIDs @@ -59,4 +62,20 @@ genTree = [ f (TC i) | i <- [-1,-2..] ] taTree = mkMT' tcl (k+1) (\t0 -> mkMT tcl (\t1 -> f (TA t0 t1))) funTree = if k==0 then mkMT tcl (\t0 -> mkMT tcl (\t1 -> f (t0 :-> t1))) else error "mkMT': the kind of functions must always be *" +mkMTIO :: TyConLib -> (Type -> IO a) -> IO (MapType a) +mkMTIO tcl f = mkMTIO' tcl 0 f +mkMTIO' :: TyConLib -> Kind -> (Type -> IO a) -> IO (MapType a) -- IO¤Î¤È¤³¤í¤ÏMonad m => m¤Ç¤è¤µ¤½¤¦¡¥¼ÂºÝ¤Ë¤ÏMonadIO¤Ç¤ä¤ë¤«¤â¡¥ +mkMTIO' tcl k f = unsafeInterleaveIO $ liftM5 MT tvTree tcTree genTree taTree funTree where + tcs = snd tcl ! k + lazyf = unsafeInterleaveIO . f + tvTree = interleaveActions $ map (f . TV) [0..] + tcTree = interleaveActions $ map (f . TC) [0..] + genTree = interleaveActions $ map (f . TC) [-1,-2..] + taTree = mkMTIO' tcl (k+1) (\t0 -> mkMTIO tcl (\t1 -> lazyf (TA t0 t1))) + funTree = mkMTIO tcl $ if k==0 then (\t0 -> mkMTIO tcl (\t1 -> lazyf (t0 :-> t1))) else error "mkMTIO': the kind of functions must always be *" +-- funTree = if k==0 then mkMTIO tcl (\t0 -> mkMTIO tcl (\t1 -> lazyf (t0 :-> t1))) else error "mkMTIO': the kind of functions must always be *" -- ¤³¤ì¤Ï´Ö°ã¤¤¡¥°ìÈÖ³°Â¦¤ËunsafeInterleaveIO¤¬¤Ê¤¤¤È¡¤kind¤¬0¤Ç¤Ê¤¤invalid¤Ê´Ø¿ô¤Î·¿¤âºî¤í¤¦¤È¤·¤Æ¤·¤Þ¤¦¡¥ + +-- I do not add unsafe because I do not understand in what sense unsafeInterleaveIO is unsafe! +interleaveActions :: [IO a] -> IO [a] +interleaveActions = foldr (\x xs -> unsafeInterleaveIO (Control.Monad.liftM2 (:) x xs)) (return []) . map unsafeInterleaveIO \end{code} diff --git a/MagicHaskeller/Execute.hs b/MagicHaskeller/Execute.hs --- a/MagicHaskeller/Execute.hs +++ b/MagicHaskeller/Execute.hs @@ -15,6 +15,8 @@ import Language.Haskell.TH hiding (Type) +import Data.Int + unDeBruijn e = undeb 0 e undeb dep (Lambda e) = lambda (dep+1) (undeb (dep+1) e) @@ -22,11 +24,11 @@ undeb dep (Y :$ e) = case undeb dep e of K :$ und -> und -- fix (\_ -> foo) = foo unde -> Y :$ unde undeb dep (e0 :$ e1) = undeb dep e0 :$ undeb dep e1 -undeb dep (Fix e n is) = undeb dep $ foldl (:$) (Y :$ FunLambda (napply n Lambda e)) (map X is) +undeb dep (Fix e n is) = undeb dep $ foldl (:$) (Y :$ FunLambda (napply (fromIntegral n) Lambda e)) (map X is) undeb dep e = e -- well, B' is not so efficient. -lambda :: Int -> CoreExpr -> CoreExpr +lambda :: Int8 -> CoreExpr -> CoreExpr lambda v e | v `isFreeIn` e = K :$ e lambda v (X n) = I lambda v (f :$ x :$ y) @@ -55,7 +57,9 @@ unsafeExecute :: VarLib -> CoreExpr -> Dynamic unsafeExecute vl e = exe (unDeBruijn e) where exe (e0 :$ e1) = dynAppErr "apply" (exe e0) (exe e1) - exe (Primitive n _) = fromPD (vl!n) + exe (Primitive n) = fromPD (vl!n) + exe (PrimCon n) = fromPD (vl!n) + exe (Context (Dict pd)) = fromPD pd exe S = $(dynamic [|defaultTCL|] [| s :: (b->c->a) -> (b->c) -> b -> a |]) exe K = $(dynamic [|defaultTCL|] [| const :: a->b->a |]) exe I = $(dynamic [|defaultTCL|] [| id :: a->a |]) diff --git a/MagicHaskeller/ExecuteAPI610.hs b/MagicHaskeller/ExecuteAPI610.hs --- a/MagicHaskeller/ExecuteAPI610.hs +++ b/MagicHaskeller/ExecuteAPI610.hs @@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS -fth -fglasgow-exts -cpp #-} +{-# LANGUAGE TemplateHaskell, MagicHash, CPP #-} -- compile with -package ghc module MagicHaskeller.ExecuteAPI610 {- (loadObj, prepareAPI, executeAPI, unsafeExecuteAPI) -} where import qualified HscMain @@ -33,7 +33,11 @@ import Lexer import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) import Desugar (deSugarExpr) +#if __GLASGOW_HASKELL__ < 708 import PrelNames ( iNTERACTIVE ) +#else +import PrelNames (mkInteractiveModule) +#endif import ErrUtils import StringBuffer (stringToStringBuffer) import Outputable (ppr, pprPanic, showSDocDebug, showSDoc) @@ -111,9 +115,12 @@ -> IO HscEnv prepareAPI fss -} -#ifdef GHC7 --- = defaultErrorHandler defaultFatalMessager defaultFlushOut $ -- This is for 7.6.1 +#if __GLASGOW_HASKELL__ >= 700 +# if __GLASGOW_HASKELL__ >= 706 + = defaultErrorHandler defaultFatalMessager defaultFlushOut $ +# else = defaultErrorHandler defaultLogAction $ +# endif #else = defaultErrorHandler defaultDynFlags $ #endif @@ -143,12 +150,12 @@ Failed -> error "failed to load modules" -- liftIO $ hPutStrLn stderr "setting up modules" -#ifdef GHC7 +#if __GLASGOW_HASKELL__ >= 700 modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":visfss) #else modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":visfss) #endif -#ifdef GHC7 +#if __GLASGOW_HASKELL__ >= 700 setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName){GHC.ideclQualified = False} | moduleName <- "Prelude":visfss ] -- GHC 7.4 #else setContext [] modules @@ -192,7 +199,7 @@ -- do mbt <- strToCore hscEnv ("let __cmCompileExpr = " ++ TH.pprint the) - do mbt <- stmtToCore hscEnv $ wrapLHsExpr $ thExpToLHsExpr the + do mbt <- stmtToCore hscEnv $ thExpToStmt hscEnv the case mbt of Nothing -> error ("could not compile " ++ TH.pprint the ++ " to core.") Just ([i ], ce) -> return ce @@ -206,7 +213,7 @@ -- unwrapCore' hscEnv ce = fmap head $ unsafeCoerce# =<< HscMain.compileExpr hscEnv (srcLocSpan interactiveSrcLoc) ce -#ifdef GHC7 +#if __GLASGOW_HASKELL__ >= 700 ce2b dfs pe = coreExprToBCOs dfs undefined pe #else ce2b dfs pe = coreExprToBCOs dfs pe @@ -217,8 +224,11 @@ = -- repeatIO 10 $ do let dfs = hsc_dflags hscEnv +#if __GLASGOW_HASKELL__ >= 706 + pe <- corePrepExpr dfs hscEnv ce -- runPrepedCoreExpr¤È¤Î°ã¤¤¤Ï¤³¤ÎcorePrepExpr¤¬¤¢¤ë¤«¤É¤¦¤«¤À¤± +#else pe <- corePrepExpr dfs ce -- runPrepedCoreExpr¤È¤Î°ã¤¤¤Ï¤³¤ÎcorePrepExpr¤¬¤¢¤ë¤«¤É¤¦¤«¤À¤± - +#endif bcos <- -- repeatIO 10 $ ce2b dfs pe @@ -254,35 +264,58 @@ fixIO (\hv -> linkBCO ie (extendClosureEnv ce [(nm,hv)]) ulbco) #endif - +-- The type of LStmt has changed during move to GHC 7.8.1. +-- stmtToCore :: HscEnv -> HsExpr.LStmt RdrName.RdrName -> IO (Maybe ([Id], CoreExpr)) stmtToCore hscEnv pst = do let dfs = hsc_dflags hscEnv icxt = hsc_IC hscEnv - (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst +#if __GLASGOW_HASKELL__ >= 708 + (tcmsgs, mbtc) <- tcRnStmt hscEnv pst +#else + (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst +#endif case mbtc of Nothing -> perror dfs tcmsgs +#if __GLASGOW_HASKELL__ >= 706 + Just (ids, tc_expr, _fixtyenv) -> do -- desugar +#else Just (ids, tc_expr) -> do -- desugar -#ifdef GHC7 - let typeEnv = mkTypeEnv (ic_tythings icxt) +#endif +#if __GLASGOW_HASKELL__ >= 708 + (desmsgs, mbds) <- deSugarExpr hscEnv tc_expr #else +# if __GLASGOW_HASKELL__ >= 700 + let typeEnv = mkTypeEnv (ic_tythings icxt) +# else let typeEnv = mkTypeEnv (map AnId (ic_tmp_ids icxt)) -#endif +# endif (desmsgs, mbds) <- deSugarExpr hscEnv iNTERACTIVE (ic_rn_gbl_env icxt) typeEnv tc_expr +#endif case mbds of Nothing -> perror dfs desmsgs Just ds -> return (Just (ids, ds)) -#ifdef GHC7 -perror dfs (wmsg,emsg) = let sdocs = pprErrMsgBag wmsg ++ pprErrMsgBag emsg in mapM_ (printError noSrcSpan) sdocs >> return Nothing +#if __GLASGOW_HASKELL__ >= 706 +perror dfs (wmsg,emsg) = printBagOfErrors dfs wmsg >> printBagOfErrors dfs emsg >> return Nothing #else +# if __GLASGOW_HASKELL__ >= 700 +perror dfs (wmsg,emsg) = let sdocs = pprErrMsgBag wmsg ++ pprErrMsgBag emsg in mapM_ (printError noSrcSpan) sdocs >> return Nothing +# else perror dfs msg = printErrorsAndWarnings dfs msg >> return Nothing +# endif #endif -thExpToStmt :: TH.Exp -> HsExpr.LStmt RdrName.RdrName -thExpToStmt = wrapLHsExpr . thExpToLHsExpr -wrapLHsExpr :: HsExpr.LHsExpr RdrName.RdrName -> HsExpr.LStmt RdrName.RdrName +-- thExpToStmt :: HscEnv -> TH.Exp -> HsExpr.LStmt RdrName.RdrName +thExpToStmt hscEnv = wrapLHsExpr . thExpToLHsExpr hscEnv +-- wrapLHsExpr :: HsExpr.LHsExpr RdrName.RdrName -> HsExpr.LStmt RdrName.RdrName wrapLHsExpr expr = noLoc $ LetStmt (HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan (Unqual $ mkOccName OccName.varName "__cmCompileExpr") [] expr)) [])) -thExpToLHsExpr :: TH.Exp -> HsExpr.LHsExpr RdrName.RdrName -thExpToLHsExpr e = case Convert.convertToHsExpr noSrcSpan e of +thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr RdrName.RdrName +thExpToLHsExpr hscEnv e = case Convert.convertToHsExpr noSrcSpan e of +#if __GLASGOW_HASKELL__ >= 706 + Left msg -> error $ showSDoc (hsc_dflags hscEnv) msg +#else Left msg -> error $ showSDoc msg +#endif Right expr -> expr +-- unused, but may be useful in future +#if __GLASGOW_HASKELL__ < 706 instance Show b => Show (Expr b) where showsPrec p (Var var) = ("Var "++) . (showSDocDebug (ppr var) ++) showsPrec _ (Lit l) = ("Lit "++) . shows l @@ -299,7 +332,7 @@ showsPrec _ (Rec ts ) = ("rec { "++) . foldr (.) id (map hoge ts) . (" } "++) hoge :: Show b => (b, Expr b) -> ShowS hoge (b, e) = shows b . (" = "++) . shows e . (" ; "++) - +#endif {- unused. also, anyPrimTy does not appear in ghc-7.* any longer -- remove the type info to see if they are necessary even when there is no ad-hoc polymorphism @@ -319,7 +352,11 @@ compileExprHscMain hscEnv ce = do let dflags = hsc_dflags hscEnv smpl <- simplifyExpr dflags ce +#if __GLASGOW_HASKELL__ >= 706 + prep <- corePrepExpr dflags hscEnv smpl +#else prep <- corePrepExpr dflags smpl +#endif bcos <- ce2b dflags prep linkExpr hscEnv noSrcSpan bcos diff --git a/MagicHaskeller/ExpToHtml.hs b/MagicHaskeller/ExpToHtml.hs --- a/MagicHaskeller/ExpToHtml.hs +++ b/MagicHaskeller/ExpToHtml.hs @@ -1,20 +1,71 @@ -module MagicHaskeller.ExpToHtml(expSigToString, refer, pprnn, annotateFree) where +{-# LANGUAGE CPP, TemplateHaskell #-} +module MagicHaskeller.ExpToHtml(QueryOptions(..), defaultQO, + versionInfo, mhVersion, ghcVersion, + review, + expToPlainString, expSigToString, refer, pprnn, annotateFree, annotateString, Language(..)) where import Language.Haskell.TH as TH import Language.Haskell.TH.PprLib(to_HPJ_Doc) import Text.PrettyPrint import Network.URI(escapeURIString, isUnreserved) import Text.Html(stringToHtmlString) -import MagicHaskeller.LibTH(fromPrelude, fromDataList, fromDataChar, fromDataMaybe, Primitive) -import Data.Char(isAlpha, ord) +import MagicHaskeller.LibTH(fromPrelude, fromDataList, fromDataChar, fromDataMaybe, Primitive, ords, prelOrdRelated, prelEqRelated, dataListOrdRelated, dataListEqRelated, fromPrelDouble, fromPrelRatio, fromDataRatio) +import Data.Char(isAlpha, ord, isDigit, isSpace, toUpper) import qualified Data.Map +import qualified Data.IntSet as IS import Data.Generics +import MagicHaskeller.CoreLang(stripByd_) +import Data.Hashable +import Data.List((\\)) +import Control.Monad(mplus) -expToString :: Exp -> String --- expToString = ('\n':) . pprint +#ifdef CABAL +import Paths_MagicHaskeller(version) +import Data.Version(showVersion) +#endif + +-- Maybe QueryOptions should be put in a new module. +data QueryOptions = Q {depth :: Int, absents :: Bool} deriving (Read, Show) +defaultQO = Q {depth = 7, absents = False} + + +versionInfo, mhVersion, ghcVersion :: String +versionInfo = mhVersion ++ " built with GHC-" ++ ghcVersion +#ifdef CABAL +mhVersion = showVersion version +#else +mhVersion = "" +#endif +ghcVersion = case __GLASGOW_HASKELL__ `divMod` 100 of (b,s) -> shows b $ '.' : show s + + +data Language = LHaskell | LExcel | LJavaScript deriving (Read, Show, Eq) + +-- | 'review' makes sure the predicate string does not use either let or where, and may correct grammatical mistakes. +-- This check should be done on both the CGI frontend side and the backend server side. +review :: Monad m => String -> m (String,Bool) +review "" = return ("",False) +review xs = case lex xs of + [("let", _)] -> fail "let" + [("where", _)] -> fail "where" + [("=", rest)] -> do (zs,_) <- review rest + return ("~= "++zs, True) + [("&", rest)] -> do (zs,_) <- review rest + return ("&& "++zs, True) + [("NaN",rest)] -> do (zs,_) <- review rest + return ("(0/0) "++zs, True) + [("Infinity",rest)] -> do (zs,_) <- review rest + return ("(1/0) "++zs, True) + [(tkn, rest)] -> do (zs,repl) <- review rest + return (tkn++' ':zs, repl) + + + + +expToPlainString, expToString :: Exp -> String +expToPlainString = ('\n':) . pprint -- expToString = (\xs -> '(':xs++")
") . {- replaceRightArrow . -} pprint . annotateEverywhere -- simple and stupid -expToString = (\xs -> '(':xs++")
") . filter (/='\n') . {- replaceRightArrow . -} pprint . annotateFree [] -- no buttons -expSigToString predStr sig expr - = mkButton predStr sig expr (pprnn (annotateFree [] expr)) -- with buttons +expToString = (\xs -> '(':xs++")
") . filter (/='\n') . {- replaceRightArrow . -} annotateString LHaskell. pprnn -- no buttons +expSigToString = mkButton -- with buttons pprnn = renderStyle style{mode=OneLineMode} . to_HPJ_Doc . pprExp 4 @@ -31,14 +82,96 @@ -- Unfortunately, w3m does not understand "++body ++ "
" -mkButton predStr sig expr body = "   "++body++"" +-- mkButton sig expr body = ""++body ++ "
" +mkButton lang predStr sig expr | usesBlackListed expr = body ++ "
" + | otherwise = "" +-- ++body++"  " + ++"  f   =   "++body + ++"" + where pprExp = pprnn expr + body = annotateString lang pprExp --
でやる場合、
をつけると改行しすぎ。 +usesBlackListed :: TH.Exp -> Bool +usesBlackListed = everything (||) (False `mkQ` (\name -> hash (nameBase name) `IS.member` partial)) +partial :: IS.IntSet +partial = IS.fromList $ map hash ["div", "mod", {- my version of -} "enumFromThenTo", "^", "head", -- "!!", -- "chr", -- used as chr . abs when auto-generated. + "init", "maximum", "minimum", "maximumBy", "minimumBy"] -escapeQuote '\'' = "'" -escapeQuote c = [c] +escapeHTML '<' = "<" +escapeHTML '>' = ">" +escapeHTML '&' = "&" +escapeHTML '"' = """ +escapeHTML '\'' = "'" +escapeHTML c = [c] + + + +-- This is the version that can annotate bound variables (if there exists a one-letter library function), but is free from the cheating of moving out the first letter. +-- Also, the unary minus cannot be distinguished from the binary (-) + +-- x #define RESPECTQUALIFICATIONS +-- 将来的には、名前が同じでもmoduleごとに違うものをちゃんと扱う。 +#ifdef RESPECTQUALIFICATIONS +annotateString lang xs = case lex xs of + [] -> error $ "parse error during annotateString: " ++ xs ++ "\nThis should not happen, when connected to the right server." + [("","")] -> "" + [(cs@(c:_),'.':rs@(r:_))] | isUpper c && not (isSpace r) -> annStr lang (cs++".") rs -- Without this pattern, '.' in "Data.Maybe.maybe" would be annotated. + [(cs,rs)] -> (if isSpace $ head xs then (' ':) else id) (annotateWord lang cs ++ annotateString lang rs) + +annStr lang mod xs = case lex xs of + [] -> error $ "parse error during annStr: " ++ xs ++"\nThis should not happen, when connected to the right server." + [("","")] -> error $ "parse error during annStr: " ++ xs ++"\nThis should not happen, when connected to the right server." + [(cs@(c:_),".":rs@(r:_))] | isUpper c && not (isSpace r) -> annStr lang (mod++cs++".") rs -- Without this pattern, '.' in "Data.Maybe.maybe" would be annotated. + [(cs,rs)] -> (if isSpace $ head xs then (' ':) else id) (annotateWord lang cs ++ annotateString lang rs) +#else +annotateString lang xs = case lex xs of + [] -> error $ "parse error during annotateString: " ++ xs ++ "\nThis should not happen, when connected to the right server." + [("","")] -> "" + [(".",rs@(r:_))] | not $ isSpace (head xs) && isSpace r -> '.' : annotateString lang rs -- Without this pattern, '.' in "Data.Maybe.maybe" would be annotated. + [(cs,rs)] -> (if isSpace $ head xs then (' ':) else id) (annotateWord lang cs ++ annotateString lang rs) +#endif + + +-- 「１単語入れればDocumentationに飛ぶ」ってやつも，「lexして残りの部分がall isSpaceならannoatateWordを実行」に拡張できる．となると，let, in, where, case of, doもいるか．さすがにclassとかtypeとかはいいでしょう．whereもいらないか．::や=>は要らないか．ま，この辺は後回しでもよい． + + -- file:///usr/share/doc/haskell98-report/html/haskell98-report-html/lexemes.html#sect2.6 -- Character and String Literals +annotateWord LHaskell cs@('\'':_) = mkLink cs "http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6" "literal" +annotateWord LHaskell cs@('"' :_) = mkLink cs "http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6" "literal" + + -- http://www.haskell.org/onlinereport/haskell2010/haskellch3.html#x8-580003.17 -- Pattern Matching + -- http://www.haskell.org/onlinereport/haskell2010/haskellch3.html#x8-590003.17.1 -- Patterns +annotateWord LHaskell cs@('_' :_) = mkLink cs "http://www.haskell.org/onlinereport/haskell2010/haskellch3.html#x8-580003.17" "keyword" + -- _１文字の場合はkeywordと考えてもよい．てか，MagHでは現状は１文字の場合しかない．keywordだと太字．まあ，_が変数名の真ん中で使えることを考えるとkeywordか． + + -- file:///usr/share/doc/haskell98-report/html/haskell98-report-html/lexemes.html#sect2.5 -- Numeric Literals +annotateWord LHaskell cs@(c :_) + | isDigit c = mkLink cs "http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-190002.5" "literal" + | otherwise = case referMb cs of Just (cls, str) -> mkLink cs str cls + Nothing | isAlpha c -> ""++cs++"" + | otherwise -> cs +annotateWord LExcel cs = case Data.Map.lookup capcs xlmap of Nothing -> cs -- bound variablesは小文字のまま。 + Just filename -> "" +-- 古いやつ +-- Just filename -> "" -- ?CTT=5&origin=HP005204211 ってのが付いてたけど、なくてもちゃんと飛んでくれる。 + ++ capcs ++ "" + where capcs = map toUpper cs +annotateWord _ [] = [] + + +xlmap :: Data.Map.Map String String +-- x #ifdef CABAL +-- x xlmap = Data.Map.fromList $ read $(fmap (LitE . StringL) $ runIO $ getDataFileName "xlmap" >>= readFile) +-- x #else +xlmap = Data.Map.fromList $ read $(fmap (LitE . StringL) $ runIO $ readFile "xlmap") +-- x #endif + + + + + +-- version that never mistakenly annotate bound variables, but is with cheating of moving out the first letter, seen in annotateName. annotateEverywhere = everywhere (mkT annotateName) annotateFree :: [String] -> TH.Exp -> TH.Exp @@ -73,21 +206,47 @@ annotateName name = case nameBase name of nameStr@(c:cs) | isAlpha c -> mkName $ c : refLink nameStr cs | c `elem` "=+!@#$%^&*-\\|:/?<>.~" -> mkName $ refLink nameStr $ stringToHtmlString nameStr _ -> name -- special names like [] and () -refLink nameStr body = "" ++ body ++ "" -refer str = case Data.Map.lookup str mapNameModule of Nothing -> referHoogle str - Just f -> f str -mapNameModule :: Data.Map.Map String (String->String) +refLink nameStr body = case refer nameStr of (cls, url) -> mkLink body url cls +refer nameStr = case referMb nameStr of Just tup -> tup + Nothing -> ("variable", referHoogle nameStr) +mkLink body url cls = ""++body++"" +referMb str = do (cls, f) <- Data.Map.lookup str mapNameModule `mplus` Data.Map.lookup (str++"By") mapNameModule + return (cls, f str) +mapNameModule :: Data.Map.Map String (String, String->String) mapNameModule = Data.Map.fromList $ mkAssoc "base" "Prelude" preludeNameBases ++ - mkAssoc "base" "Data-List" (primssToStrs fromDataList) ++ - mkAssoc "base" "Data-Char" (primssToStrs fromDataChar) ++ - mkAssoc "base" "Data-Maybe" (primssToStrs fromDataMaybe) -mkAssoc package mod namebases = [ (str, referHackage package mod) | str <- namebases ] + mkAssoc "base" "Data-List" (["\\\\"] ++ primssToStrs fromDataList ++ [ stripByd_ nm | nm <- primssToStrs $ dataListOrdRelated ++ dataListEqRelated ]) ++ + mkAssoc "base" "Data-Char" dataCharNameBases ++ + mkAssoc "base" "Data-Maybe" (primssToStrs fromDataMaybe) ++ + mkAssoc "base" "Data-Ratio" (primssToStrs fromDataRatio) ++ + [ (kw, ("keyword", const $ repch3 ++ str)) | (kw, str) <- [ + ("@", "#x8-580003.17"), -- Pattern Matching + ("~", "#x8-580003.17"), -- Pattern Matching + ("..", "#x8-400003.10"), -- Arithmetic Sequences + ("\\", "#x8-260003.3"), -- Curried Applications and Lambda Abstractions + ("->", "#x8-260003.3"), -- Curried Applications and Lambda Abstractions + ("if", "#x8-320003.6"), -- Conditionals + ("then","#x8-320003.6"), -- Conditionals + ("else","#x8-320003.6"), -- Conditionals + (":", "#x8-340003.7") -- Lists + ] ] ++ + [ (kw, ("other", const $ repch3 ++ str)) | (kw, str) <- [ + ("[", ""), -- There are some possibilities, so the syntax is pointed. + ("]", ""), + ("`", "#x8-240003.2"), -- Variables, Constructors, Operators, and Literals + ("-", "#x8-280003.4") -- Operator Applications + ] ] +repch3 = "http://www.haskell.org/onlinereport/haskell2010/haskellch3.html" -preludeNameBases = ["iterate", "!!", "id", "$", "const", ".", "flip", "subtract", "maybe", "foldr", "zipWith"] ++ -- These are not included in the component library, but introduced by MagicHaskeller.LibTH.postprocess. - primssToStrs fromPrelude +mkAssoc package mod namebases = [ (str, ("variable", referHackage package mod)) | str <- namebases ] -primssToStrs = map TH.nameBase . primsToNames . concat +preludeNameBases = ["iterate", "!!", "id", "$", "const", ".", "flip", "subtract", "maybe", "foldr", "foldl", "zipWith", "either", "last"] ++ -- These are not included in the component library, but introduced by MagicHaskeller.LibTH.postprocess. + (primssToStrs fromPrelude \\ [":","-"]) ++ primssToStrs fromPrelDouble ++ primssToStrs fromPrelRatio ++ [ stripByd_ nm | nm <- primssToStrs $ prelOrdRelated ++ prelEqRelated ] +dataCharNameBases = ["chr"] ++ + primssToStrs fromDataChar + +primssToStrs = primsToStrs . concat +primsToStrs = map TH.nameBase . primsToNames primsToNames :: [Primitive] -> [TH.Name] primsToNames ps = [ name | (_, VarE name, _) <- ps ] ++ [ name | (_, ConE name, _) <- ps ] ++ [ name | (_, _ `AppE` VarE name, _) <- ps ] -- ad hoc approach to the (flip foo) cases:) diff --git a/MagicHaskeller/ExprStaged.hs b/MagicHaskeller/ExprStaged.hs --- a/MagicHaskeller/ExprStaged.hs +++ b/MagicHaskeller/ExprStaged.hs @@ -18,6 +18,9 @@ import MagicHaskeller.TyConLib(defaultTCL, tuplename) import MagicHaskeller.ReadTHType(typeToTHType) +import Data.Int +import Data.List(genericTake, genericSplitAt) + see i j = pprint $ e2THE $ mkCE i j seeType i j = unDeBruijn $ mkCE i j @@ -77,7 +80,7 @@ mkXs = mkVNames 'x' mkHd = newName "hd" -hdmnTHEQ :: Int -> Int -> ExpQ +hdmnTHEQ :: Int8 -> Int8 -> ExpQ hdmnTHEQ m n = return $ (VarE 'unsafeCoerce#) `AppE` hdmnTHE m n {- hdmnTHEQ m n = do hd <- mkHd @@ -88,7 +91,7 @@ appa1an var = foldl AppE (VarE var) $ map VarE nas return $ (VarE 'unsafeCoerce#) `AppE` lambdas (foldl AppE (VarE hd) (map appa1an mes)) -} -aimnTHEQ :: Int -> Int -> Int -> ExpQ +aimnTHEQ :: Int8 -> Int8 -> Int8 -> ExpQ aimnTHEQ i m n = return $ (VarE 'unsafeCoerce#) `AppE` aimnTHE i m n {- aimnTHEQ i m n = do @@ -99,23 +102,23 @@ return $ (VarE 'unsafeCoerce#) `AppE` lambdas (foldl AppE (VarE (nas!!i)) (map appa1an mes)) -} -hdmnTHE :: Int -> Int -> Exp +hdmnTHE :: Int8 -> Int8 -> Exp hdmnTHE m n = e2THE (mkCE n m) -aimnTHE :: Int -> Int -> Int -> Exp +aimnTHE :: Int8 -> Int8 -> Int8 -> Exp aimnTHE i m n = e2THE (mkCE_LambdaBoundHead i n m) -- copied from ExecuteAPI $B$F$f!<$+!$(BmkCE_LambdaBoundHead$B$G$O(Bde Bruijn index$B$r;H$C$F$$$k$,!$(BExecuteAPI.aimn$B$O5U8~$-$K(Bindex$B$r3d$jEv$F$F$$$k$N$G!$$=$N$^$^;}$C$F$-$F$O%@%a!%(B -hdmnty :: Int -> Int -> Types.Type +hdmnty :: Int8 -> Int8 -> Types.Type hdmnty m n = hdty Types.:-> foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs) where hdty = foldr (Types.:->) tvr mrs - mrs = take m tvrs - nas = take n tvas -aimnty :: Int -> Int -> Int -> Types.Type + mrs = genericTake m tvrs + nas = genericTake n tvas +aimnty :: Int8 -> Int8 -> Int8 -> Types.Type aimnty i m n = foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs) where hdty = foldr (Types.:->) tvr mrs - mrs = take m tvrs - nas = case splitAt (n-i-1) tvas of (tk,_:dr) -> tk ++ hdty : take i dr -- hdmnty$B$H$N0c$$$O$3$3$@$1(B -mkTV :: Int -> Types.Type + mrs = genericTake m tvrs + nas = case genericSplitAt (n-i-1) tvas of (tk,_:dr) -> tk ++ hdty : genericTake i dr -- hdmnty$B$H$N0c$$$O$3$3$@$1(B +mkTV :: Types.TyVar -> Types.Type mkTV = Types.TV tvrs = map mkTV [1,3..] tvas = map mkTV [2,4..] @@ -124,15 +127,15 @@ -- $B0J2<$N?tCM$O!$$I$N%5%$%:$^$GD>@\(Bsupercombinator$B$rMQ0U$9$k$+$rI=$9!%(B -- $B$3$NHO0O$K<}$^$i$J$$>l9g$G$b!$(Bprimitive combinators$B$G%;%3%;%3$7$J$1$l$P$J$i$J$$$H$$$&Lu$G$O$J$$(B -maxArity, maxLenavails :: Int +maxArity, maxLenavails :: Int8 maxArity = 4 maxLenavails = 8 -- $B4pK\E*$K2?2s4X?t9g@.$9$k$+$NLdBj$J$N$G!$$?$H$($P(B13$B$H$+$J$i(B8+5$B$H9M$($F(B2$B2s9g@.$7$F$b$=$s$J$K8zN($OMn$A$J$$!$$H;W$&!%(B maxDebindex = maxLenavails-1 -- maxArity = 0 -- maxLenavails = 0 -mkCE :: Int -- ^ length of avails - -> Int -- ^ arity of the head function +mkCE :: Int8 -- ^ length of avails + -> Int8 -- ^ arity of the head function -> CoreExpr mkCE 0 _ = Lambda (X 0) mkCE lenavail 0 = napply (lenavail+1) Lambda (X lenavail) diff --git a/MagicHaskeller/Expression.hs b/MagicHaskeller/Expression.hs --- a/MagicHaskeller/Expression.hs +++ b/MagicHaskeller/Expression.hs @@ -1,6 +1,7 @@ -- -- (c) Susumu Katayama -- +{-# LANGUAGE CPP #-} module MagicHaskeller.Expression(module MagicHaskeller.Expression, module MagicHaskeller.ExprStaged, CoreExpr) where import MagicHaskeller.CoreLang import MagicHaskeller.MyDynamic @@ -23,7 +24,7 @@ import qualified Data.Set as S import qualified Data.IntMap as IM -import Data.List(sortBy) +import Data.List(sortBy, genericIndex) -- AnnExpr remembers each Dynamic corresponding to the CoreExpr. data AnnExpr = AE CoreExpr Dynamic deriving Show @@ -48,20 +49,23 @@ meToAE :: MemoExpr -> AnnExpr meToAE (ME ce _ f) = AE ce f +{-# SPECIALIZE mkHead :: (CoreExpr->Dynamic) -> Int -> Int -> CoreExpr -> e #-} +{-# SPECIALIZE mkHead :: (CoreExpr->Dynamic) -> Int8 -> Int8 -> CoreExpr -> e #-} class (Ord e, Show e) => Expression e where - mkHead :: (CoreExpr->Dynamic) -> Int -> Int -> CoreExpr -> e + mkHead :: (Integral i, Integral j) => (CoreExpr->Dynamic) -> i -> j -> CoreExpr -> e toCE :: e -> CoreExpr fromCE :: (CoreExpr -> Dynamic) -> CoreExpr -> e mapCE :: (CoreExpr -> CoreExpr) -> e -> e -- $B$3$l$bJQ!%(B - (<$>) :: e -> e -> e - appEnv :: Int -> e -> e -> e + aeAppErr :: String -> e -> e -> e + appEnv :: Int8 -> e -> e -> e toAnnExpr :: (CoreExpr->Dynamic) -> e -> AnnExpr toAnnExprWind :: (CoreExpr->Dynamic) -> Type -> e -> AnnExpr toAnnExprWindWind :: (CoreExpr->Dynamic) -> Type -> e -> AnnExpr fromAnnExpr :: AnnExpr -> e - reorganize :: Monad m => ([Type] -> m [e]) -> [Type] -> m [e] + reorganize :: Monad m => ([Type] -> m [e]) -> [Type] -> m [e] -- with uniq + reorganize' :: Monad m => ([Type] -> m [e]) -> [Type] -> m [e] -- without uniq reorganizeId :: ([Type] -> [e]) -> [Type] -> [e] -- reorganize for Id monad - replaceVars' :: Int -> e -> [Int] -> e -- @replaceVars@ without uniq + replaceVars' :: Int8 -> e -> [Int8] -> e -- @replaceVars@ without uniq reorganizeId' :: (Functor m) => ([Type] -> m e) -> [Type] -> m e reorganizeId' fun avail = case cvtAvails' avail of (args, newavail) -> @@ -72,31 +76,43 @@ toCE = id fromCE _ = id mapCE = id - (<$>) = (:$) + aeAppErr _msg = (:$) appEnv _ = (:$) toAnnExpr reduce e = AE e (reduce e) toAnnExprWind reduce ty e = AE e (reduce $ windType ty e) toAnnExprWindWind reduce ty e = let we = windType ty e in AE we (reduce we) fromAnnExpr (AE ce _) = ce reorganize = reorganizer + reorganize' = reorganizeCE' reorganizeId = reorganizerId replaceVars' = replaceVarsCE' instance Expression AnnExpr where - mkHead _ lenavails arity ce@(X i) = AE ce (getDyn_LambdaBoundHead i lenavails arity) -- Note that 'dynss' and 'dynsss' uses - mkHead reduce lenavails arity ce = AE ce ((getDyn lenavails arity) `dynApp` reduce ce) -- 'unsafeExecute' instead of 'reduce'. + mkHead reduce lenavails arity ce = mkHeadAE reduce (fromIntegral lenavails) (fromIntegral arity) ce toCE (AE ce _) = ce fromCE = toAnnExpr mapCE f (AE ce d) = AE (f ce) d - AE e1 h1 <$> AE e2 h2 = AE (e1:$e2) (dynApp h1 h2) +#ifdef REALDYNAMIC + aeAppErr msg (AE e1 h1) (AE e2 h2) = AE (e1:$e2) (dynAppErr (" while applying "++show e1 ++" to "++show e2 ++ '\n':msg) h1 h2) +#else + aeAppErr _msg (AE e1 h1) (AE e2 h2) = AE (e1:$e2) (dynApp h1 h2) +#endif appEnv lenavails (AE e1 h1) (AE e2 h2) = AE (e1:$e2) (dynApp (dynApp (dynSn lenavails) h1) h2) toAnnExpr _ = id toAnnExprWind _ _ = id toAnnExprWindWind _ ty (AE ce d) = AE (windType ty ce) d fromAnnExpr = id reorganize = id + reorganize' = id reorganizeId = id reorganizeId' = id -- Well, this is overridden to id because replaceVars' for AnnExpr is not yet implemented. -- $B$F$JLu$G!%) :: Expression e => e -> e -> e +(<$>) = aeAppErr "" + +mkHeadAE _ lenavails arity ce@(X i) = AE ce (getDyn_LambdaBoundHead i lenavails arity) -- Note that 'dynss' and 'dynsss' uses +mkHeadAE reduce lenavails arity ce = AE ce ((getDyn lenavails arity) `dynApp` reduce ce) -- 'unsafeExecute' instead of 'reduce'. + windType :: Type -> CoreExpr -> CoreExpr windType (a:->b) e = Lambda (windType b e) windType _ e = e @@ -104,12 +120,12 @@ -- Sn = \f g x1 .. xn -> f x1 .. xn (g x1 .. xn) dynSn lenavails = dynApp (getDyn lenavails 2) dynI -getDyn, mkDyn :: Int -> Int -> Dynamic +getDyn, mkDyn :: Int8 -> Int8 -> Dynamic getDyn lenavails arity -- | arity<=maxArity = case lenavails `divMod` maxLenavails of (d,m) -> napply d (dynApp (dynApp dynB (finiteDynar!(maxLenavails,arity)))) (finiteDynar!(m,arity)) -- $B$J$s$+0c$&$_$?$$!%(B | lenavails<=maxLenavails && arity<=maxArity = -- trace (show (lenavails,arity)++show (maxLenavails,maxArity)) $ finiteDynar ! (lenavails,arity) - | otherwise = dynss !! lenavails !! arity + | otherwise = dynss `genericIndex` lenavails `genericIndex` arity dynss :: [[Dynamic]] dynss = [ [ mkDyn i j | j <- [0..] ] | i <- [0..] ] @@ -131,8 +147,8 @@ -- #endif x n = napply n (dynApp dynB) dynS `dynApp` x (n-1) -finiteDynar = array ((0,0),(maxLenavails,maxArity)) [ ((lenavails,arity), finiteDynss!!lenavails!!arity) | arity<-[0..maxArity], lenavails<-[0..maxLenavails] ] -finiteDynarr = array ((0,0,0),(maxDebindex,maxLenavails,maxArity)) [ ((debindex,lenavails,arity), finiteDynsss!!debindex!!(lenavails-debindex-1)!!arity) | arity<-[0..maxArity], debindex<-[0..maxDebindex], lenavails<-[debindex+1..maxLenavails] ] +finiteDynar = array ((0,0),(maxLenavails,maxArity)) [ ((lenavails,arity), finiteDynss `genericIndex` lenavails `genericIndex` arity) | arity<-[0..maxArity], lenavails<-[0..maxLenavails] ] +finiteDynarr = array ((0,0,0),(maxDebindex,maxLenavails,maxArity)) [ ((debindex,lenavails,arity), finiteDynsss `genericIndex` debindex `genericIndex` (lenavails-debindex-1) `genericIndex` arity) | arity<-[0..maxArity], debindex<-[0..maxDebindex], lenavails<-[debindex+1..maxLenavails] ] finiteDynss = zipWith3 (zipWith3 (unsafeToDyn defaultTCL)) [ [ hdmnty arity lenavails | arity <- [0..maxArity] ] | lenavails <- [0..maxLenavails] ] finiteHVss @@ -142,15 +158,16 @@ finiteHVsss [ [ [ aimnTHE debindex arity lenavails | arity <- [0..maxArity] ] | lenavails <- [debindex+1..maxLenavails] ] | debindex <- [0..maxDebindex] ] -getDyn_LambdaBoundHead, mkDyn_LambdaBoundHead :: Int -> Int -> Int -> Dynamic +getDyn_LambdaBoundHead, mkDyn_LambdaBoundHead :: Int8 -> Int8 -> Int8 -> Dynamic getDyn_LambdaBoundHead debindex lenavails arity | debindex<=maxDebindex && lenavails<=maxLenavails && arity<=maxArity = -- trace (show (debindex,lenavails,arity)++show (maxDebindex,maxLenavails,maxArity)) $ finiteDynarr ! (debindex,lenavails,arity) -- $B$3$C$A$NJ}$,8zN(E*$J$s$@$1$I!$%G%P%C%0Cf$@$10l;~E*$K!%(B -- finiteDynsss !! debindex !! (lenavails-debindex-1) !! arity - | otherwise = dynsss !! debindex !! lenavails !! arity + | otherwise = dynsss `genericIndex` debindex `genericIndex` lenavails `genericIndex` arity dynsss :: [[[Dynamic]]] dynsss = [ [ [ mkDyn_LambdaBoundHead i j k | k <- [0..] ] | j <- [0..] ] | i <- [0..] ] + mkDyn_LambdaBoundHead debindex lenavails arity = (getDyn lenavails (arity+1) `dynApp` dynI) `dynApp` select lenavails debindex where -- select lenavails debindex = unsafeExecute (napply lenavails Lambda $ X debindex) @@ -175,7 +192,7 @@ = case cvtAvails avail of (newavail, argss) -> [ result | e <- fun newavail, result <- replaceVars 0 e argss ] -replaceVars :: Int -> CoreExpr -> [[Int]] -> [CoreExpr] +replaceVars :: Int8 -> CoreExpr -> [[Int8]] -> [CoreExpr] replaceVars dep e@(X n) argss = case argss !? (n - dep) of Nothing -> [e] Just xs -> map (\ m -> X (m + dep)) xs replaceVars dep (Lambda e) argss = map Lambda (replaceVars (dep+1) e argss) @@ -184,12 +201,12 @@ cvtAvails = unzip . tkr10 . annotate -tkr10 :: [(Type,Int)] -> [(Type,[Int])] +tkr10 :: [(Type,a)] -> [(Type,[a])] tkr10 = mergesortWithBy (\ (k,is) (_,js) -> (k,is++js)) (\ (k,_) (l,_) -> k `compare` l) . map (\(k,i)->(k,[i])) -- annotate$B$O(BsplitAvails$B$NA0=hM}$H$7$F$b;H$($k!%(B -annotate :: [Type] -> [(Type,Int)] +annotate :: [Type] -> [(Type,Int8)] annotate ts = zipWith (,) ts [0..] {- annotate ts = an 0 ts @@ -202,14 +219,14 @@ -- @reorganize@ without uniq -reorganize' :: Monad m => ([Type] -> m [CoreExpr]) -> [Type] -> m [CoreExpr] -reorganize' fun avail +reorganizeCE' :: Monad m => ([Type] -> m [CoreExpr]) -> [Type] -> m [CoreExpr] +reorganizeCE' fun avail = case cvtAvails' avail of (args, newavail) -> do agentExprs <- fun newavail return [ replaceVars' 0 e args | e <- agentExprs ] -replaceVarsCE' :: Int -> CoreExpr -> [Int] -> CoreExpr +replaceVarsCE' :: Int8 -> CoreExpr -> [Int8] -> CoreExpr replaceVarsCE' dep e@(X n) args = case args !? (n - dep) of Nothing -> e Just m -> X (m + dep) replaceVarsCE' dep (Lambda e) args = Lambda (replaceVarsCE' (dep+1) e args) diff --git a/MagicHaskeller/FMType.lhs b/MagicHaskeller/FMType.lhs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/FMType.lhs @@ -0,0 +1,110 @@ +further simplified from ~/svn/MagicHaskeller/allifdefs/FMType.lhs + +\begin{code} +{-# OPTIONS -cpp #-} +module MagicHaskeller.FMType(FMType(..), updateFMT, unionFMT, unitFMT, lookupFMT, fmtToList, eltsFMT, + {- listToFMT, -} mapFMT + ) where +import MagicHaskeller.Types +-- import Monad +import Data.IntMap as IM + +-- import CoreLang + +import Data.Monoid + +data FMType a = EmptyFMT + | FMT { + tvFMT :: IntMap a, + tcFMT :: IntMap a, + taFMT :: (FMType (FMType a)), + fnFMT :: (FMType (FMType a)), + funFMT :: (FMType (FMType a)) + } + deriving (Read, Show) + +lookupFMT :: Type -> FMType a -> Maybe a +lookupFMT _ EmptyFMT = Nothing +lookupFMT (TV tv) fmt = IM.lookup (fromIntegral tv) (tvFMT fmt) +lookupFMT (TC tc) fmt = IM.lookup (fromIntegral tc) (tcFMT fmt) +lookupFMT (TA t0 t1) fmt = lookupFMTFMT t0 t1 (taFMT fmt) +#ifdef RIGHTFMT +lookupFMT (t0 :> t1) fmt = lookupFMTFMT t0 t1 (fnFMT fmt) +lookupFMT (t0 :-> t1) fmt = lookupFMTFMT t0 t1 (funFMT fmt) +#else +lookupFMT (t1 :> t0) fmt = lookupFMTFMT t0 t1 (fnFMT fmt) +lookupFMT (t1 :-> t0) fmt = lookupFMTFMT t0 t1 (funFMT fmt) +#endif +lookupFMTFMT t0 t1 fmtfmt = lookupFMT t0 fmtfmt >>= lookupFMT t1 + +mapFMT :: (Type -> a -> b) -> FMType a -> FMType b -- takes the index as an argument, like mapFM, but currently only the structures of the types are considered. +mapFMT f EmptyFMT = EmptyFMT +mapFMT f (FMT v c a n u) = FMT (mapWithKey (\tv -> f (TV $ fromIntegral tv)) v) + (mapWithKey (\tc -> f (TC $ fromIntegral tc)) c) + (mapFMT (\t0 -> mapFMT (\t1 -> f (TA t0 t1))) a) + (mapFMT (\t0 -> mapFMT (\t1 -> f (t1 :> t0))) n) + (mapFMT (\t0 -> mapFMT (\t1 -> f (t1 :-> t0))) u) + +{- addToFMT$B$H(BlistToFMT$B$C$F2?$G%3%a%s%H%"%&%H$7$?$s$@$C$1!)(B $B$"$H!$(Bnormalize$B$7$J$$J}$,$h$$!)(B +addToFMT :: Typed a -> FMType a -> FMType a +addToFMT (e:::ty) = updateFMT (et:) et nty + where nty = normalize ty + et = e:nty +listToFMT :: [Typed a] -> FMType a +listToFMT = foldr addToFMT EmptyFMT +-} + + +eltsFMT :: FMType a -> [a] +eltsFMT EmptyFMT = [] +eltsFMT (FMT vs cs as fs fus) = elems vs ++ elems cs ++ [ x | fmt <- eltsFMT as, x <- eltsFMT fmt ] ++ [ x | fmt <- eltsFMT fs, x <- eltsFMT fmt ] ++ [ x | fmt <- eltsFMT fus, x <- eltsFMT fmt ] + +{- +fmtToList :: FMType a -> [Typed a] +-- fmtToList = eltsFMT . mapFMT (\t a -> a:::t) +fmtToList EmptyFMT = [] +fmtToList (FMT vs cs as fs fus) = fmToTypedVars vs ++ fmToTypedCons cs ++ [ x ::: TA t0 t1 | fmt:::t0 <- fmtToList as, x:::t1 <- fmtToList fmt ] ++ [ x ::: (t1 :> t0) | fmt:::t0 <- fmtToList fs, x:::t1 <- fmtToList fmt ] ++ [ x ::: (t1 :-> t0) | fmt:::t0 <- fmtToList fus, x:::t1 <- fmtToList fmt ] +fmToTypedVars fm = map (\ (tv,x) -> x ::: TV tv) (fmToList fm) +fmToTypedCons fm = map (\ (tc,x) -> x ::: TC tc) (fmToList fm) +-} +fmtToList :: FMType a -> [(Type,a)] +-- fmtToList = eltsFMT . mapFMT (\t a -> (t,a)) +fmtToList EmptyFMT = [] +fmtToList (FMT vs cs as fs fus) = fmToTypedVars vs ++ fmToTypedCons cs ++ [ (TA t0 t1, x) | (t0, fmt) <- fmtToList as, (t1,x) <- fmtToList fmt ] ++ [ (t1 :> t0, x) | (t0,fmt) <- fmtToList fs, (t1,x) <- fmtToList fmt ] ++ [ (t1 :-> t0, x) | (t0,fmt) <- fmtToList fus, (t1,x) <- fmtToList fmt ] +fmToTypedVars fm = Prelude.map (\ (tv,x) -> (TV $ fromIntegral tv, x)) (toList fm) +fmToTypedCons fm = Prelude.map (\ (tc,x) -> (TC $ fromIntegral tc, x)) (toList fm) + +updateFMT :: (a->a) -> a -> Type -> (FMType a) -> FMType a +updateFMT f x t fmt = updFMT t fmt + where updFMT t EmptyFMT = updFMT t (FMT empty empty EmptyFMT EmptyFMT EmptyFMT) + updFMT (TV gen) fmt = fmt{tvFMT = insertWith (\_new old -> f old) (fromIntegral gen) x (tvFMT fmt)} + updFMT (TC con) fmt = fmt{tcFMT = insertWith (\_new old -> f old) (fromIntegral con) x (tcFMT fmt)} + updFMT (TA t0 t1) fmt = fmt{taFMT = updateFMT updFMTt1 (updFMTt1 EmptyFMT) t0 (taFMT fmt)} + where updFMTt1 = updFMT t1 + updFMT (t0 :> t1) fmt = fmt{fnFMT = updateFMT updFMTt0 (updFMTt0 EmptyFMT) t1 (fnFMT fmt)} + where updFMTt0 = updFMT t0 + updFMT (t0 :-> t1) fmt = fmt{funFMT = updateFMT updFMTt0 (updFMTt0 EmptyFMT) t1 (funFMT fmt)} + where updFMTt0 = updFMT t0 + +unitFMT x t = updateFMT undefined x t EmptyFMT +-- used by FMSubst.lhs + +instance Monoid a => Monoid (FMType a) where + mappend = unionFMT mappend + mempty = EmptyFMT + +-- unionFMT is used by TypedTries. +unionFMT :: (a->a->a) -> FMType a -> FMType a -> FMType a +unionFMT f l r = uFMT l r + where uFMT EmptyFMT fmt = fmt + uFMT fmt EmptyFMT = fmt + uFMT (FMT vl cl al nl ul) (FMT vr cr ar nr ur) = FMT (unionWith f vl vr) (unionWith f cl cr) (unionFMT uFMT al ar) (unionFMT uFMT nl nr) (unionFMT uFMT ul ur) +{- +unionFMT :: (forall a. a->a->a) -> FMType b -> FMType b -> FMType b +unionFMT f EmptyFMT fmt = fmt +unionFMT f fmt EmptyFMT = fmt +unionFMT f (FMT vl cl al nl ul) (FMT vr cr ar nr ur) = FMT (plusFM_C f vl vr) (plusFM_C f cl cr) (unionFMT (unionFMT f) al ar) (unionFMT (unionFMT f) nl nr) (unionFMT (unionFMT f) ul ur) +-} + + +\end{code} diff --git a/MagicHaskeller/FakeDynamic.hs b/MagicHaskeller/FakeDynamic.hs --- a/MagicHaskeller/FakeDynamic.hs +++ b/MagicHaskeller/FakeDynamic.hs @@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama -- -{-# LANGUAGE MagicHash, ExistentialQuantification, PolymorphicComponents, TemplateHaskell #-} +{-# LANGUAGE MagicHash, ExistentialQuantification, PolymorphicComponents, TemplateHaskell, ImpredicativeTypes #-} module MagicHaskeller.FakeDynamic( Dynamic, fromDyn, diff --git a/MagicHaskeller/FastRatio.hs b/MagicHaskeller/FastRatio.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/FastRatio.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} +module MagicHaskeller.FastRatio where +#if __GLASGOW_HASKELL__ >= 706 +import Prelude hiding(Ratio, Rational, (%)) +#else +import Prelude hiding(Rational) +#endif +import qualified Data.Ratio +import Data.Typeable +import Data.Bits +-- import Test.QuickCheck hiding (choose) +-- import GHC.Integer.GMP.Internals + +-- So, the integral type is totally ignored! +data Ratio a = !Integer :% !Integer deriving Typeable + +type Rational = Ratio Integer + +(%) :: Integral a => a -> a -> Ratio a +x % y = toInteger x :% toInteger y +numerator, denominator :: Integral a => Ratio a -> a +numerator (n:%d) = let (n':%_ ) = reduce n d in fromInteger $ n' * signum d +denominator (n:%d) = let (_ :%d') = reduce n d in fromInteger $ abs d' + +notANumber = 0:%0 + +reduce _ 0 = notANumber +reduce x y = (x `quot` d) :% (y `quot` d) + where d = gcd x y + +choose :: Ratio a -> Ratio a +-- choose = id + +choose v@(n:%d) = if (abs n .|. abs d) > 0x3FFFFFFFFFFFFFFF then + reduce n d else v + +instance Ord (Ratio a) where + x:%y <= x':%y' = case compare 0 $ y * y' of + EQ -> False + LT -> x * y' <= x' * y + GT -> x * y' >= x' * y + x:%y < x':%y' = case compare 0 $ y * y' of + EQ -> False + LT -> x * y' < x' * y + GT -> x * y' > x' * y + compare (x:%y) (x':%y') = case compare 0 $ y * y' of + EQ -> EQ -- This conflicts the definition of (==) and (<=). + -- compare is used for the random-testing filters, while (==) is used by the predicate filter. + -- (But actually, compare is also used for the sortBy....) + LT -> compare (x * y') (x' * y) + GT -> compare (x' * y) (x * y') + +instance Eq (Ratio a) where + x:%y == x':%y' = (y * y') /= 0 && x*y' == x'*y + x:%y /= x':%y' = (y * y') /= 0 && x*y' /= x'*y + +instance Integral a => Num (Ratio a) where + (x:%y) + (x':%y') = choose $ (x*y' + x'*y) :% (y*y') + (x:%y) - (x':%y') = choose $ (x*y' - x'*y) :% (y*y') + (x:%y) * (x':%y') = choose $ (x * x') :% (y*y') + negate (x:%y) = (-x):%y + abs (x:%y) = abs x :% abs y + signum (x:%0) = notANumber + signum (x:%y) = signum (x * y) :% 1 + fromInteger x = fromInteger x :% 1 + +instance Integral a => Fractional (Ratio a) where + x:%y / x':%y' = if y' == 0 then notANumber else choose $ (x*y') :% (y*x') + recip (x:%y) | y == 0 = notANumber + | otherwise = y:%x + fromRational r = Data.Ratio.numerator r :% Data.Ratio.denominator r + +instance Integral a => RealFrac (Ratio a) where + properFraction (x:%y) = (fromInteger q, r :% y) + where (q,r) = quotRem x y + +instance (Show a, Integral a) => Show (Ratio a) where + showsPrec p r + = showParen (p > 7) $ + showsPrec 8 (numerator r) . + showString " % " . + showsPrec 8 (denominator r) +instance Integral a => Real (Ratio a) where + toRational (x:%y) = x Data.Ratio.% y + +instance Integral a => Enum (Ratio a) where + succ x = x + 1 + pred x = x - 1 + + toEnum n = fromIntegral n :% 1 + fromEnum = fromInteger . truncate +{- + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = numericEnumFromTo + enumFromThenTo = numericEnumFromThenTo +-} + +{- properties held. +prop_LE a b c d = c/=0 && d/=0 ==> let r1 = a%c <= b%d + r2 = a Data.Ratio.% c <= b Data.Ratio.% d + in r1 == r2 +prop_LT a b c d = c/=0 && d/=0 ==> let r1 = a%c < b%d + r2 = a Data.Ratio.% c < b Data.Ratio.% d + in r1 == r2 +prop_EQ a b c d = c/=0 && d/=0 ==> let r1 = a%c == b%d + r2 = a Data.Ratio.% c == b Data.Ratio.% d + in r1 == r2 + +prop_plus a b c d = c/=0 && d/=0 ==> let r1 = a%c + b%d + r2 = a Data.Ratio.% c + b Data.Ratio.% d + in toRational r1 == r2 +prop_minus a b c d = c/=0 && d/=0 ==> let r1 = a%c - b%d + r2 = a Data.Ratio.% c - b Data.Ratio.% d + in r1 == fromRational r2 +prop_times a b c d = c/=0 && d/=0 ==> let r1 = a%c * b%d + r2 = (a Data.Ratio.% c) * (b Data.Ratio.% d) + in numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 +prop_negate a b = b/=0 ==> let r1 = negate $ a%b + r2 = negate $ a Data.Ratio.% b + in numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 +prop_abs a b = b/=0 ==> let r1 = abs $ a%b + r2 = abs $ a Data.Ratio.% b + in numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 +prop_signum a b = b/=0 ==> let r1 = signum $ a%b + r2 = signum $ a Data.Ratio.% b + in numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 +prop_fromInteger a b = let r1 = fromInteger a + r2 = fromInteger a + in numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 + +prop_div a b c d = b/=0 && c/=0 && d/=0 ==> let r1 = a%c / b%d + r2 = (a Data.Ratio.% c) / (b Data.Ratio.% d) + in numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 +prop_recip a b = a/=0 && b/=0 ==> let r1 = recip $ a%b + r2 = recip $ a Data.Ratio.% b + in numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 +prop_properFraction a b = b/=0 ==> let (i1,r1) = properFraction $ a%b + (i2,r2) = properFraction $ a Data.Ratio.% b + in i1 == i2 && numerator r1 == Data.Ratio.numerator r2 && denominator r1 == Data.Ratio.denominator r2 +prop_showsPrec p a b = b/=0 ==> let r1 = showsPrec p $ a%b + r2 = showsPrec p $ a Data.Ratio.% b + in r1 [] == r2 [] +-} diff --git a/MagicHaskeller/IOGenerator.hs b/MagicHaskeller/IOGenerator.hs --- a/MagicHaskeller/IOGenerator.hs +++ b/MagicHaskeller/IOGenerator.hs @@ -1,50 +1,80 @@ -- -- (c) Susumu Katayama -- -{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, IncoherentInstances #-} -- Used by the Web version. -module MagicHaskeller.IOGenerator where +module MagicHaskeller.IOGenerator(module MagicHaskeller.IOGenerator, NearEq((~=))) where +#ifdef TFRANDOM +import System.Random.TF.Gen +import System.Random.TF.Instances +#else import System.Random +#endif import MagicHaskeller.MyCheck -import Data.List(sort, group, sortBy, intersperse) +import Data.List(sort, group, sortBy, groupBy, nubBy, intersperse) import Data.Function(on) import Data.Char(isAlphaNum) -import Data.Ratio +-- import Data.Ratio +import MagicHaskeller.FastRatio import MagicHaskeller.LibTH(everythingF, pgfull, postprocess) -import MagicHaskeller.ExpToHtml(pprnn, annotateFree) +import MagicHaskeller.ExpToHtml(pprnn, annotateString, Language(..)) -- annotateFree is replaced with annotateString import Language.Haskell.TH(pprint, Exp) import Data.Typeable +import Text.Html(stringToHtmlString) +import MagicHaskeller.NearEq(NearEq((~=))) + +#ifdef TFRANDOM arbitraries :: Arbitrary a => [a] +arbitraries = arbs 4 (seedTFGen (12279932681387497184,218462391894233257,1625759680792809304,12756118543158863164)) +arbs :: Arbitrary a => Int -> TFGen -> [a] +arbs n stdgen = case map (splitn stdgen 8) [0..255] of + g0:gs -> map (f n) gs ++ arbs n g0 -- I think 255 seeds is enough, but just in case. + where Gen f = arbitrary +#else +arbitraries :: Arbitrary a => [a] arbitraries = arbs 4 (mkStdGen 1) arbs :: Arbitrary a => Int -> StdGen -> [a] arbs n stdgen = case split stdgen of (g0,g1) -> f n g0 : arbs n g1 where Gen f = arbitrary +#endif --showIOPairs :: IOGenerator a => String -> String -> a -> String --showIOPairs crlf funname fun = concat $ map ((crlf ++) . (funname++)) $ generate fun -showIOPairsHTML :: IOGenerator a => String -> a -> String +showIOPairsHTML :: String -> [ShownIOPair] -> String showIOPairsHTML = showIOPairsHTML' (const showIOPairHTML) -showIOPairsWithFormsHTML :: IOGenerator a => - String -- ^ CGI.myPath, which is usually "/cgi-bin/MagicHaskeller.cgi" +showIOPairsWithFormsHTML :: String -- ^ CGI.myPath, which is usually "/cgi-bin/MagicHaskeller.cgi" -> String -- ^ predicate before escaping single quotes - -> String -> a -> String + -> String -> [ShownIOPair] -> String showIOPairsWithFormsHTML mypath predicate = let beginForm = " && "++) . (funname++) . shower boxSize) iopairs - where iopairs = generateIOPairs fun - boxSize = maximum $ 20 : map length (snd $ unzip iopairs) +showIOPairsHTML' :: (Int -> ShownIOPair -> String) -> String -> [ShownIOPair] -> String +showIOPairsHTML' shower funname iopairs + = concat $ map (("&& "++) . (funname++) . shower boxSize) {- (nubSortedOn iopairToInputs -} iopairs -- Instead, nubOn is applied to showArbitraries. + where boxSize = maximum $ 20 : map length (snd $ unzip iopairs) -type AnnShowS = (Exp->Exp) -- ^ annotater +nubOn f = map snd . nubBy ((==) `on` fst) . map (\x -> (f x, x)) +nubSortedOn f = map snd . nubSortedOn' fst . map (\x -> (f x, x)) +nubSortedOn' f = map head . groupBy ((==) `on` f) . sortBy (compare `on` f) + +type ShownIOPair = ([AnnShowS], String) + +iopairToInputs :: ShownIOPair -> [String] +iopairToInputs (funs,_) = map assToString funs +assToString :: AnnShowS -> String +assToString fun = fun id "" + +type AnnShowS = (String->String) -- ^ annotater -> String -> String -showIOPairHTML (args,ret) = foldr (\arg str -> "  " ++ arg (annotateFree []) str) ("   ==    "++ret++ "  ") args +showIOPairHTML :: ShownIOPair -> String +showIOPairHTML (args,ret) = foldr (\arg str -> "  " ++ arg (annotateString LHaskell) str) ("   ~=    "++ret++ "  ") args showIOPairWithFormHTML begin boxSize pair@(args,ret) = showIOPairHTML (args, mkForm begin boxSize pair) mkForm :: String -> Int - -> ([AnnShowS],String) + -> ShownIOPair -> String -- predicate¤Èinputs¤Èoutput¤¬¤¢¤ì¤Ð¤è¤¤¡¥CGI¦¤Ç¤Ï¡¤ '(':predicate++") && f "++inputs++" == "++output ¤òpredicate¤È¤·¤Æ¼Â¹Ô mkForm begin boxSize (args,ret) @@ -55,7 +85,7 @@ class IOGenerator a where -- generate :: a -> [String] - generateIOPairs :: a -> [([AnnShowS],String)] -- list of pairs of shown arguments and shown return values + generateIOPairs :: a -> [ShownIOPair] -- list of pairs of shown arguments and shown return values instance (IOGenerator r) => IOGenerator (Int->r) where -- generate f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] generateIOPairs = generateIOPairsLitNum integrals @@ -69,6 +99,8 @@ -- generate f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] generateIOPairs = generateIOPairsLitNum arbitraries +generateIOPairsLitNum :: (Num a, Ord a, Show a, IOGenerator b) => + [a] -> (a -> b) -> [ShownIOPair] -- Can be used for Integer, Double, and Float, but not for Ratio and Complex. generateIOPairsLitNum rs f = [ (const (showParen (a<0) (shows a)) : args, ret) | a <- uniqSort $ take 4 rs, (args,ret) <- generateIOPairs (f a) ] @@ -86,7 +118,7 @@ generateIOPairs f = generateIOPairsFun False f instance (IOGenerator r) => IOGenerator (Char->r) where -- generate f = generateFun False f - generateIOPairs f = [ (const (shows a) : args, ret) | a <- " \nAb."{- ++ take 0 arbitraries -}, (args,ret) <- generateIOPairs (f a) ] + generateIOPairs f = [ (const (stringToHtmlString (show a) ++) : args, ret) | a <- " \nAb."{- ++ take 0 arbitraries -}, (args,ret) <- generateIOPairs (f a) ] instance (IOGenerator r) => IOGenerator (String->r) where -- generate f = generateFun False f @@ -119,8 +151,10 @@ -- generate f = generateFun True f generateIOPairs = mhGenerateIOPairs +mhGenerateIOPairs :: (ShowArbitrary a, IOGenerator b) => + (a -> b) -> [ShownIOPair] mhGenerateIOPairs f = [ (astr : args, ret) - | (astr, a) <- take 5 showArbitraries, + | (astr, a) <- take 5 $ nubOn (assToString . fst) showArbitraries, (args, ret) <- generateIOPairs (f a) ] -- | 'ShowArbitrary' is a variant of 'Arbitrary' for presenting I/O example pairs. It uses everythingF for generating printable functions. @@ -177,8 +211,9 @@ -- ¤Û¤ó¤È¤Ï¤â¤Ã¤È¥é¥ó¥À¥à¤Ë¤¹¤Ù¤­¤Ç¤Ï¤¢¤ë¡¥2ËÜ[a]¤¬¤¢¤ë¾ì¹ç¡¤Æ±¤¸arbitraries::[Int]¤ò¶¦Í­¤¹¤ë¤Î¤Ç¡¤Æ±¤¸²Õ½ê¤ÇƱ¤¸Ä¹¤µ¤Ë¤Ê¤ë¡¥ chopBy :: [Int] -> [a] -> [[a]] chopBy _ [] = [] -- everythingF¤ò»È¤Ã¤Æ¤¢¤ëÅÀ¤ÇÀÚ¤ë¸Â¤ê¡¤Í­¸Â¤Î²ÄǽÀ­¤âɬ¤º»Ä¤ë¡¥¶õ¥ê¥¹¥È¤Ç¤¢¤ë¤³¤È¤â¤¢¤ê¤¨¤ë¤Î¤Ç¡¤cycle¤·¤Æ¤â¥À¥á¡¥ -chopBy (i:is) xs | i < 0 = chopBy is xs - | otherwise = case splitAt i xs of (tk,dr) -> tk : chopBy is dr +chopBy is xs = cb is $ cycle xs + where cb (i:is) xs | i < 0 = cb is xs + | otherwise = case splitAt i xs of (tk,dr) -> tk : cb is dr cvt :: [(AnnShowS,a)] -> (AnnShowS, [a]) cvt ts = case unzip ts of (fs, xs) -> (showsList fs, xs) @@ -187,9 +222,9 @@ showsList fs = \annotater -> ('[':) . foldr (.) (']':) (intersperse (',':) $ map ($ annotater) fs) instance (Typeable a, Typeable b) => ShowArbitrary (a->b) where - showArbitraries = map (\(e,a) -> (\annotater -> (pprnn (annotater (postprocess e)) ++) , a)) $ concat $ take 3 $ everythingF pgfull - + showArbitraries = map (\(e,a) -> (\annotater -> (annotater (pprnn (postprocess e)) ++) , a)) $ concat $ take 5 $ everythingF pgfull True +generateIOPairsFun :: (Ord a, Show a, Arbitrary a, IOGenerator b) => Bool -> (a->b) -> [ShownIOPair] -- generateFun b f = [ ' ' : showParen b (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] generateIOPairsFun b f = [ (const (showParen b (shows a)) : args, ret) | a <- uniqSort $ take 5 arbitraries @@ -197,7 +232,7 @@ instance Show a => IOGenerator a where -- generate x = [" = "++show x] - generateIOPairs x = [([], show x)] + generateIOPairs x = [([], stringToHtmlString $ show x)] uniqSort :: Ord a => [a] -> [a] uniqSort = map head . group . sort diff --git a/MagicHaskeller/Instantiate.hs b/MagicHaskeller/Instantiate.hs --- a/MagicHaskeller/Instantiate.hs +++ b/MagicHaskeller/Instantiate.hs @@ -1,16 +1,21 @@ -- -- (c) Susumu Katayama -- -{-# LANGUAGE TemplateHaskell, RankNTypes, CPP #-} +{-# LANGUAGE TemplateHaskell, RankNTypes, CPP, PatternGuards, ImpredicativeTypes #-} module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries, - uncurryDyn, uncurryTy, mkUncurry, typeToOrd, typeToRandomsOrd, typeToRandomsOrdDM, mkCurry, curryDyn + uncurryDyn, uncurryTy, mkUncurry, typeToOrd, typeToRandomsOrd, typeToRandomsOrdDM, mkCurry, curryDyn, argTypeToRandoms , typeToArb -- exported just for testing Classification.tex + , PackedOrd, typeToCompare, compareRealFloat ) where import MagicHaskeller.CoreLang import qualified Data.Map as Map import MagicHaskeller.MyCheck +#ifdef TFRANDOM +import System.Random.TF.Gen +#else import System.Random +#endif import MagicHaskeller.Types import Control.Monad.Search.Combinatorial import Data.Array((!)) @@ -20,6 +25,9 @@ import Control.Monad import qualified Data.IntMap as IntMap +-- import Data.Ratio +import MagicHaskeller.FastRatio + import MagicHaskeller.MyDynamic hiding (dynApp) -- import Data.Typeable @@ -31,6 +39,9 @@ -- import ReadTypeRep(typeToTR) import Language.Haskell.TH hiding (Type) + +import MagicHaskeller.NearEq(NearEq(..)) + -- import Debug.Trace trace _ e = e @@ -128,13 +139,18 @@ type PackedOrd = Dynamic -> Dynamic -> Ordering type Cmp a = a->a->Ordering -type Maps = (ArbMap, ArbMap, StdGen, StdGen) -- used if we do not memoize +#ifdef TFRANDOM +type Generator = TFGen +#else +type Generator = StdGen +#endif +type Maps = (ArbMap, CoarbMap, Generator, Generator) -- used if we do not memoize type Tries = (MapType (Maybe [Dynamic]), MapType (Maybe [[Dynamic]])) -- used if we memoize type RTrie = (CmpMap, Maps, MemoMap, Tries, MapType (Dynamic,Dynamic)) -mkRandTrie :: [Int] -> TyConLib -> StdGen -> RTrie +mkRandTrie :: [Int] -> TyConLib -> Generator -> RTrie mkRandTrie nrnds tcl gen = let arbtup = mkArbMap tcl coarbtup = mkCoarbMap tcl @@ -161,14 +177,16 @@ -- ¤Æ¤æ¡¼¤«¡¤argTypeToRandomss¤À¤±¤ÇÁ´Éô¤ä¤ì¤Ð¤¤¤¤¤ó¤À¤±¤É¡¥ type MapTC a = IntMap.IntMap (IntMap.IntMap a) -type CmpMap = (MapTC Dynamic, Dynamic) +type CmpMap = (MapTC Dynamic, SpecialMap, Dynamic) mkMap :: TyConLib -> [[(String,a)]] -> MapTC a -mkMap tcl@(mapNameTyCon,_) mcts = IntMap.fromAscList $ zip [0..] $ map (IntMap.fromList . map (\ (name, dyn) -> (mapNameTyCon Map.! name, dyn))) mcts +mkMap tcl@(mapNameTyCon,_) mcts = IntMap.fromAscList $ zip [0..] $ map (IntMap.fromList . map (\ (name, dyn) -> (fromIntegral (mapNameTyCon Map.! name), dyn))) mcts mkCmpMap :: TyConLib -> CmpMap mkCmpMap tcl = (mkMap tcl [mct0, mct1, mct2], - cmpChar) + mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| compareRatio :: Ratio Int -> Ratio Int -> Ordering |])), + ("Ratio", "Integer", $(dynamic [|tcl|] [| compareRatio :: Ratio Integer -> Ratio Integer -> Ordering |]))], + cmpChar) where cmpChar = $(dynamic [|tcl|] [| compare :: Char -> Char -> Ordering |]) mct0, mct1, mct2 :: [(String,Dynamic)] @@ -176,8 +194,8 @@ ("Integer", $(dynamic [|tcl|] [| compare :: Integer -> Integer -> Ordering |])), ("Char", cmpChar), ("Bool", $(dynamic [|tcl|] [| compare :: Bool -> Bool -> Ordering |])), - ("Double", $(dynamic [|tcl|] [| compare :: Double -> Double -> Ordering |])), - ("Float", $(dynamic [|tcl|] [| compare :: Float -> Float -> Ordering |])), + ("Double", $(dynamic [|tcl|] [| compareRealFloat :: Double -> Double -> Ordering |])), + ("Float", $(dynamic [|tcl|] [| compareRealFloat :: Float -> Float -> Ordering |])), ("()", $(dynamic [|tcl|] [| compare :: () -> () -> Ordering |])), ("Ordering",$(dynamic [|tcl|] [| compare :: Ordering-> Ordering-> Ordering |]))] mct1 = [("Maybe", $(dynamic [|tcl|] [| compareMaybe :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering |])), @@ -193,6 +211,19 @@ compareMaybe _ Nothing _ = LT compareMaybe _ _ Nothing = GT compareMaybe cmp (Just x) (Just y) = cmp x y +compareRatio :: Integral i => Ratio i -> Ratio i -> Ordering +compareRatio x y = case (denominator x, denominator y) of (0,0) -> EQ -- Because the comparison is just for removing duplicates efficiently, + (0,_) -> LT -- notANumber should be a normal element here. + (_,0) -> GT + _ -> compare (numerator x * denominator y) (numerator y * denominator x) +compareRealFloat :: (NearEq a, RealFloat a) => a->a->Ordering +compareRealFloat x y = case (isNaN x, isNaN y) of -- Because the comparison is just for removing duplicates efficiently, + (True, True) -> EQ -- NaN should be a normal element here. + (True, False) -> LT + (False,True) -> GT + (False,False) -> if x~=y then EQ else compare x y + + compareList _ [] [] = EQ compareList _ [] _ = LT compareList _ _ [] = GT @@ -209,19 +240,23 @@ typeToCompare tcl cmap ty = do cmp <- typeToOrd cmap ty return (dynToCompare tcl cmp) typeToOrd :: CmpMap -> Type -> Maybe Dynamic -typeToOrd (cmpmap,cmpchar) ty = tto 0 ty - where tto k (TA t u) = liftM2 dynApp (tto (k+1) t) (tto 0 u) -- Higher-order kinds break everything. +typeToOrd (cmpmap,spmap,cmpchar) ty = tto 0 ty + where tto 0 (TA (TC tc1) (TC tc2)) | Just dyn <- IntMap.lookup (combineTCs tc1 tc2) spmap = return dyn + tto k (TA t u) = liftM2 dynApp (tto (k+1) t) (tto 0 u) -- Higher-order kinds break everything. tto _ (_:->_) = Nothing -- error "Functions in containers are not allowed." -- note that ty is (part of) the return type, so this means higher-order datatype is returned. tto 0 (TV _) = Just cmpchar -- same as the Char case tto _ (TV _) = Nothing -- ¤³¤ì¤Ë¤Ä¤¤¤Æ¤Ï°ìÈÌŪ¤Ê¤ä¤ê¤«¤¿¤Ï¤Ê¤µ¤½¤¦¡¥ tto k (TC tc) = do guard (tc >= 0) imap <- IntMap.lookup k cmpmap - IntMap.lookup tc imap + IntMap.lookup (fromIntegral tc) imap tto _ _ = Nothing -type ArbMap = (MapTC Dynamic, Dynamic, Dynamic) +type ArbMap = (MapTC Dynamic, SpecialMap, Dynamic, Dynamic) +type CoarbMap = (MapTC Dynamic, SpecialMap, Dynamic, Dynamic) mkArbMap :: TyConLib -> ArbMap mkArbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3], + mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| arbitraryRatio :: Gen (Ratio Int) |])), + ("Ratio", "Integer", $(dynamic [|tcl|] [| arbitraryRatio :: Gen (Ratio Integer) |]))], arbChar, -- same as the Char case $(dynamic [|tcl|] [| arbitraryFun :: (a -> Gen b -> Gen b) -> Gen b -> Gen (a->b) |]) ) @@ -243,8 +278,25 @@ ("(,)", $(dynamic [|tcl|] [| arbitraryPair :: Gen a -> Gen b -> Gen (a, b) |]))] mct3 = [("(,,)", $(dynamic [|tcl|] [| arbitraryTriplet :: Gen a -> Gen b -> Gen c -> Gen (a,b,c) |]))] -typeToArb :: ArbMap -> ArbMap -> Type -> Maybe Dynamic -typeToArb arbtup@(arbmap,arbchar,arbfun) coarbtup@(coarbmap,coarbchar,coarbfun) ty = tta 0 ty +-- ArbMap specialized for Ratio Int, etc. +-- This is necessary because we cannot have something like arbitraryRatio :: Gen a -> Gen (Ratio a) (without type constraint), +-- in order to avoid zero-denominator cases. +type SpecialMap = IntMap.IntMap Dynamic +mkSpecialMap :: TyConLib -> [(String,String,Dynamic)] -> IntMap.IntMap Dynamic +mkSpecialMap tcl@(mapNameTyCon,_) = IntMap.fromList . map (\ (name1, name2, dyn) -> (combineTCs (mapNameTyCon Map.! name1) (mapNameTyCon Map.! name2), dyn)) + +{- ¤³¤Ã¤Á¤Ë¤¹¤Ù¤­ --------------------------------------- +-- This signature silently makes sure that TyCon == Int8. This should cause an error when TyCon /= Int8. +combineTCs :: Int8 -> Int8 -> Int +combineTCs tc1 tc2 = fromIntegral tc1 * 256 + fromIntegral tc2 +-} +-- debugÌÜŪ¤Ç¤³¤Ã¤Á¤Ë¤·¤Æ¤¤¤ë¡£--------------------------------- +combineTCs :: TyCon -> TyCon -> Int +combineTCs tc1 tc2 = fromIntegral tc1 * 256 + fromIntegral tc2 + + +typeToArb :: ArbMap -> CoarbMap -> Type -> Maybe Dynamic +typeToArb arbtup@(arbmap, spmap, arbchar, arbfun) coarbtup@(coarbmap, _, coarbchar, coarbfun) ty = tta 0 ty where tta 0 ty@(t :-> u) = do coarb <- typeToCoarb arbtup coarbtup t arb <- tta 0 u @@ -255,14 +307,17 @@ tta k (TC tc) = do guard (tc >= 0) imap <- IntMap.lookup k arbmap - IntMap.lookup tc imap + IntMap.lookup (fromIntegral tc) imap + tta 0 (TA (TC tc1) (TC tc2)) | Just dyn <- IntMap.lookup (combineTCs tc1 tc2) spmap = return dyn tta k (TA t0 t1) = do arb0 <- tta (k+1) t0 arb1 <- tta 0 t1 return (-- trace ("t0 = "++show t0++" and t1 = "++show t1) $ dynApp arb0 arb1) tta _ _ = Nothing -mkCoarbMap :: TyConLib -> ArbMap +mkCoarbMap :: TyConLib -> CoarbMap mkCoarbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3], + mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| coarbitraryRatio :: Ratio Int -> Gen x -> Gen x |])), + ("Ratio", "Integer", $(dynamic [|tcl|] [| coarbitraryRatio :: Ratio Integer -> Gen x -> Gen x |]))], coarbChar, -- same as the Char case $(dynamic [|tcl|] [| coarbitraryFun :: Gen a -> (b -> Gen x -> Gen x) -> (a->b) -> Gen x -> Gen x |]) ) @@ -285,8 +340,8 @@ mct3 = [("(,,)", $(dynamic [|tcl|] [| coarbitraryTriplet:: (a -> Gen x -> Gen x) -> (b -> Gen x -> Gen x) -> (c -> Gen x -> Gen x) -> (a,b,c) -> Gen x -> Gen x |]))] -typeToCoarb :: ArbMap -> ArbMap -> Type -> Maybe Dynamic -typeToCoarb arbtup@(arbmap,arbchar,arbfun) coarbtup@(coarbmap,coarbchar,coarbfun) ty = ttc 0 ty +typeToCoarb :: ArbMap -> CoarbMap -> Type -> Maybe Dynamic +typeToCoarb arbtup@(arbmap,_,arbchar,arbfun) coarbtup@(coarbmap,spmap,coarbchar,coarbfun) ty = ttc 0 ty where -- ttc :: Type -> Maybe (Coarb Dynamic) ttc 0 ty@(t :-> u) = do arb <- typeToArb arbtup coarbtup t coarb <- ttc 0 u @@ -296,7 +351,8 @@ ttc k (TC tc) = do guard (tc >= 0) imap <- IntMap.lookup k coarbmap - IntMap.lookup tc imap + IntMap.lookup (fromIntegral tc) imap + ttc 0 (TA (TC tc1) (TC tc2)) | Just dyn <- IntMap.lookup (combineTCs tc1 tc2) spmap = return dyn ttc k (TA t0 t1) = do arb0 <- ttc (k+1) t0 arb1 <- ttc 0 t1 return (-- trace ("arb0 = "++show arb0++"arb1 = "++show arb1) $ @@ -364,7 +420,7 @@ ttc _ (TV _) = Nothing ttc k (TC tc) | tc < 0 = Nothing | otherwise = do imap <- IntMap.lookup k memomap - IntMap.lookup tc imap + IntMap.lookup (fromIntegral tc) imap ttc k (TA t0 t1) = do (m0,a0) <- ttc (k+1) t0 (m1,a1) <- ttc 0 t1 return (dynApp m0 m1, dynApp a0 a1) @@ -372,14 +428,14 @@ -- Test.QuickCheck.Gen¤ÏRandom.StdGen¸ÂÄê¤Ç¡¤¤½¤ì°Ê³°¤ÎRandomGen g => g¤Ç¤Ï¥À¥á¤ß¤¿¤¤¡¥ -- Test.QuickCheck.generate¤ÎÄêµÁ¤¬¤Á¤ç¤Ã¤ÈÊѤÀ¤È»×¤¦¡¥usable¤À¤È¤Ï»×¤¦¤±¤É¡¥ -type Arb a = StdGen -> [a] +type Arb a = Generator -> [a] arbitrariesByDyn :: TyConLib -> Dynamic -> Arb Dynamic arbitrariesByDyn tcl arb = arbsByDyn tcl arb 0 -arbsByDyn :: TyConLib -> Dynamic -> Int -> StdGen -> [Dynamic] +arbsByDyn :: TyConLib -> Dynamic -> Int -> Generator -> [Dynamic] arbsByDyn tcl arbDyn depth stdgen = zipWith (genAppDyn tcl arbDyn) [depth..] (gens stdgen) -genAppDyn :: TyConLib -> Dynamic -> Int -> StdGen -> Dynamic +genAppDyn :: TyConLib -> Dynamic -> Int -> Generator -> Dynamic genAppDyn tcl arbDyn size stdgen = dynApp $(dynamic [|tcl|] [| (\(Gen f) -> f size stdgen) :: Gen a -> a |] ) arbDyn {- ¼ÂºÝ¤â¤¦»È¤ï¤ì¤Æ¤¤¤Ê¤¤¤·¡¥´Ö°ã¤¨¤Æ¤³¤Ã¤Á¤òÊÔ½¸¤·¤Á¤ã¤¦¤Î¤Ç¡¤±£¤¹¡¥ @@ -395,10 +451,14 @@ -- nrnds¤Ï¼Â¤Ïsize¤ò·è¤á¤ë¤¿¤á¤Ë¤·¤«»È¤ï¤ì¤Æ¤¤¤Ê¤¤¡¥ÆÀ¤é¤ì¤ë¤Î¤ÏStream (Bag Dynamic)¤Ç¤Ï¤Ê¤¯Stream (Stream Dynamic) -arbitrariessByDyn :: [Int] -> TyConLib -> Dynamic -> StdGen -> [[Dynamic]] +arbitrariessByDyn :: [Int] -> TyConLib -> Dynamic -> Generator -> [[Dynamic]] arbitrariessByDyn nrnds tcl arb gen = abd nrnds tcl arb 0 gen -- abd _ _ arb depth gen = zipWith (arbsByDyn arb) [depth..] (gens gen) -- Íð¿ô¥µ¥¤¥º¤ò¾®¤µ¤¤Ãͤ«¤éÁý¤ä¤·¤Æ¤¤¤¯¾ì¹ç abd nrnds tcl arb depth gen = zipWith (arbsByDyn' nrnds tcl arb) [depth..] (gens gen) -- Íð¿ô¥µ¥¤¥º¤ò°ìÄê¤Ë¤¹¤ë¾ì¹ç arbsByDyn' nrnds tcl arbDyn depth stdgen = map (genAppDyn tcl arbDyn size) (gens stdgen) where size = max depth (nrnds !! depth) +#ifdef TFRANDOM +gens gen = case map (splitn gen 8) [0..255] of g0:gs -> gs ++ gens g0 +#else gens gen = case split gen of (g0,g1) -> g0 : gens g1 +#endif diff --git a/MagicHaskeller/LibExcel.hs b/MagicHaskeller/LibExcel.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/LibExcel.hs @@ -0,0 +1,328 @@ +-- +-- (c) Susumu Katayama +-- +{-# OPTIONS -XTemplateHaskell -XNoMonomorphismRestriction -cpp #-} +module MagicHaskeller.LibExcel(module MagicHaskeller.LibExcel, module MagicHaskeller.LibExcelStaged) where + +import MagicHaskeller +import MagicHaskeller.LibExcelStaged +import MagicHaskeller.Types(size) +import Control.Monad(liftM2) +import Data.List hiding (tail) +import Data.Char +import Data.Maybe +-- import Data.Ratio +import MagicHaskeller.FastRatio +import qualified Data.Generics as G + +import MagicHaskeller.ProgGenSF(mkTrieOptSFIO) + +import qualified Data.IntMap as IM +import Data.Hashable + +import Prelude hiding (tail, gcd, enumFromThenTo) + +-- whether succ is used only for numbers or not +succOnlyForNumbers = True -- This is True for Excel. + +-- total variants of prelude functions +last' = (\x xs -> last (x:xs)) +tail = drop 1 +-- init xs = zipWith const xs (drop 1 xs) + + +-- | 'ppExcel' replaces uncommon functions like catamorphisms with well-known functions. +ppExcel :: Exp -> Exp +ppExcel (AppE (AppE (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) e5) e6) | Just stem <- stripPrefix "6'" $ reverse nb = mkUncurried (reverse stem) (map ppExcel [e1, e2, e3, e4, e5, e6]) + where nb = nameBase name +ppExcel (AppE (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) e5) | Just stem <- stripPrefix "5'" $ reverse nb = mkUncurried (reverse stem) (map ppExcel [e1, e2, e3, e4, e5]) + where nb = nameBase name +ppExcel (AppE (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) e5) | nameBase name == "." = ppExcel $ ((e1 `AppE` (e2 `AppE` e3)) `AppE` e4) `AppE` e5 -- ad hoc pattern:S +ppExcel (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) | nameBase name == "." = ppExcel $ (e1 `AppE` (e2 `AppE` e3)) `AppE` e4 +ppExcel (AppE (AppE (AppE (AppE (ConE name) e1) e2) e3) e4) | nameBase name == "(,,,)" = ppExcel $ TupE [e1, e2, e3, e4] +ppExcel (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) | nb == "flip" = ppExcel $ ((e1 `AppE` e3) `AppE` e2) `AppE` e4 + | nb == "sUBST4" = mkUncurried "sUBSTITUTE" (map ppExcel [e1, e2, e3, mkVarOp lit1 "+" (absE `AppE` e4)]) + | Just stem <- stripPrefix "4'" $ reverse nb = mkUncurried (reverse stem) (map ppExcel [e1, e2, e3, e4]) + where nb = nameBase name +ppExcel (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) | nameBase name == "." = ppExcel $ e1 `AppE` (e2 `AppE` e3) +ppExcel (AppE (e@(AppE (AppE (ConE name) p) t)) f) | nameBase name == "(,,)" = ppExcel $ TupE [p,t,f] +ppExcel (AppE (e@(AppE (AppE (VarE name) p) t)) f) + = case reverse $ nameBase name of + "xIdnif" -> mkVarOp (mkUncurried "finD" [char7, mkUncurried "sUBSTITUTE" [mkUncurried "concatenate" [ppp,ppt], ppp, char7, ppExcel $ mkVarOp lit1 "+" (absE `AppE` f) ]]) "-" lit1 -- The "findIx" case. findIx c xs n = finD(char(7), sUBSTITUTE(concatenate(c,xs), c, char(7), 1+abs(n)))-1 + "pilf" -> ppExcel $ (ppp `AppE` ppf) `AppE` ppt -- The "flip" case + "." -> ppExcel (p `AppE` (t `AppE` f)) + '3':'\'':stem -> ppExcel $ mkUncurried (reverse stem) [p,t,f] + _ -> ppExcel e `AppE` ppf + where ppp = ppExcel p + ppt = ppExcel t + ppf = ppExcel f +ppExcel (AppE f@(AppE (ConE name) lj) e) | nameBase name == "(,)" = ppExcel $ TupE [lj, e] +ppExcel (AppE (AppE (VarE name) e1) e2) | nb == "fLOOR0" = case ppe2 of LitE (IntegerL n) | n>0 -> floore1e2 + | otherwise -> lit0 + LitE (RationalL n) | n>0 -> floore1e2 + | otherwise -> lit0 + AppE (VarE nm) _ | nameBase nm == "pI" -> floore1e2 -- just to avoid the awkward case of iF(pI() > 0, blah) + _ -> mkIF (mkVarOp ppe2 ">" lit0) floore1e2 lit0 + | nb == "countStr" = case ppe2 of LitE (StringL "") -> lit0 + LitE (StringL _) -> counted + ListE [] -> lit0 + ListE _ -> counted + _ -> mkIF (mkVarOp ppe2 "<>" (LitE $ StringL "")) counted lit0 + | nb == "dropLeft" = mkUncurried "right" [ppe1, mkVarOp (ppExcel $ lenE `AppE` ppe1) "-" ppe2] + | Just stem <- stripPrefix "2'" $ reverse nb = ppExcel $ mkUncurried (reverse stem) [e1, e2] + where nb = nameBase name + ppe1 = ppExcel e1 + ppe2 = ppExcel e2 + counted = ppExcel $ mkVarOp (mkVarOp (lenE `AppE` e1) "-" (lenE `AppE` (mkSUBST4 [e1, ppe2, LitE (StringL "")]))) "/" (lenE `AppE` ppe2) -- countStr x str = (len(x)-len(sUBsTITUTE(x,str,""))) / len(str) + floore1e2 = mkUncurried "fLOOR" [ppe1, ppe2] +ppExcel (AppE (InfixE m@(Just _) op Nothing) e) = ppExcel (InfixE m op (Just e)) +ppExcel (AppE (InfixE Nothing op m@(Just _)) e) = ppExcel (InfixE (Just e) op m) +ppExcel (AppE v@(VarE name) e) + = case nameBase name of + "tail" -> ppdrop 1 e + "negate" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ (-i) + LitE (RationalL r) -> LitE $ RationalL $ (-r) + _ -> mkVarOp (LitE $ IntegerL 0) "-" ppe -- @negate x@ should become @0 - x@ + "abs" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ abs i + LitE (RationalL r) -> LitE $ RationalL $ abs r + ParensE _ -> AppE (ppv v) ppe + _ -> AppE (ppv v) $ ParensE ppe + "floor" -> ppe + "fromIntegral" -> ppe + "succ" -> case ppe of + LitE (IntegerL i) -> LitE $ IntegerL $ succ i + LitE (RationalL r) -> LitE $ RationalL $ succ r + LitE (CharL c) -> LitE $ CharL $ succ c + InfixE (Just (LitE (IntegerL n))) (VarE nm) (Just e) + | nameBase nm == "+" -> mkVarOp (LitE $ IntegerL $ succ n) "+" e + AppE (VarE nm) e + | succOnlyForNumbers && + nameBase nm == "succ" -> mkVarOp (LitE $ IntegerL 2) "+" e -- This is OK, if we use succ only for numbers. + _ -> AppE (ppv v) ppe + "left1" -> case ppe of + LitE (StringL xs) -> LitE $ StringL $ take 1 xs + ListE es -> ListE $ take 1 $ map ppExcel es + ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> ListE [LitE $ IntegerL f] + AppE (VarE name) e' | nameBase name == "left1" -> ppe + _ -> AppE leftE $ TupE [ppe, LitE $ IntegerL 1] + "right1" -> case ppe of + LitE (StringL xs) -> LitE $ StringL $ right(xs,1) + ListE es -> ListE $ right(map ppExcel es, 1) + AppE (VarE name) e' | nameBase name == "right1" -> ppe + _ -> AppE rightE $ TupE [ppe, LitE $ IntegerL 1] + "reverse" -> case ppe of + LitE (StringL xs) -> LitE $ StringL $ reverse xs + ListE es -> ListE $ reverse $ map ppExcel es + ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> ArithSeqE $ FromThenToR (LitE $ IntegerL t) (LitE $ IntegerL $ t-1) (LitE $ IntegerL f) + AppE (VarE name) e' | nameBase name == "reverse" -> e' + _ -> AppE reverseE ppe + "len" -> case ppe of + LitE (StringL xs) -> LitE $ IntegerL $ toInteger $ length xs + ListE es -> LitE $ IntegerL $ toInteger $ length es + ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> LitE $ IntegerL $ t - f + 1 -- can be bottom, if t is less than f. + AppE (VarE name) e' | nameBase name == "reverse" -> AppE lenE e' -- length . reverse => length + -- There can also be the length . map f => length rule. The length . map f pattern can appear when f includes some absent argument. + ParensE _ -> AppE lenE ppe + _ -> AppE lenE (ParensE ppe) + "sum" -> case ppe of + AppE (VarE name) e' | nameBase name == "reverse" -> AppE sumE e' + _ -> AppE sumE ppe + "product" -> case ppe of + AppE (VarE name) e' | nameBase name == "reverse" -> AppE productE e' + _ -> AppE productE ppe + nb -> case ppe of + TupE _ -> AppE (ppv v) ppe + ConE name | nameBase name == "()" -> AppE (ppv v) ppe + _ -> AppE (ppv v) (ParensE ppe) + where ppe = ppExcel e +-- The following pattern is actually unnecessary if only eta-long normal expressions will be generated. +ppExcel e@(VarE _) = ppv e +ppExcel e@(ConE _) = ppv e +ppExcel (AppE f x) = case ppx of + TupE _ -> ppExcel f `AppE` ppx + _ -> ppExcel f `AppE` ParensE ppx + where ppx = ppExcel x +ppExcel (InfixE me1 op me2) + = let j1 = fmap ppExcel me1 + j2 = fmap ppExcel me2 + in case op of + VarE opname -> + case (j1,j2) of + (Just (LitE (IntegerL i1)), Just (LitE (IntegerL i2))) -> + case nameBase opname of "+" -> LitE $ IntegerL $ i1+i2 + "-" -> LitE $ IntegerL $ i1-i2 + "*" -> LitE $ IntegerL $ i1*i2 + _ -> theDefault + (Just (LitE (IntegerL i1)), Just (InfixE (Just (LitE (IntegerL i2))) (VarE inopn) me3)) + | nameBase opname == "+" && nameBase inopn `elem` ["+","-"] -> InfixE (Just $ LitE $ IntegerL $ i1+i2) (VarE $ ppopn inopn) me3 + (Just e, Just (LitE (IntegerL 1))) + | nameBase opname `elem` ["/","*"] -> e + _ -> theDefault + where theDefault = InfixE j1 (VarE $ ppopn opname) j2 + +ppExcel (LamE pats e) = LamE pats (ppExcel e) + +ppExcel (TupE es) = TupE (map ppExcel es) +ppExcel (ListE es) = ListE (map ppExcel es) +ppExcel (SigE e ty) = ppExcel e `SigE` ty +ppExcel e = e + + +{- +ppv e@(VarE name) | nameBase name `elem` ["iF", "nat_cata"] = LamE [ VarP n | n <- names ] (ppExcel (AppE (AppE (AppE e p) t) f)) + | nameBase name == "last'" = LamE [ VarP n | n <- tail names ] (ppExcel (AppE (AppE e t) f)) + | otherwise = VarE $ ppopn name + where names = [ mkName [n] | n <- "ptf" ] + [p,t,f] = map VarE names +-} +ppv (VarE name) = VarE $ ppopn name +ppv (ConE name) = ConE $ ppopn name +ppopn name = mkName $ nameBase name + + + +ppdrop m0j e + = case ppExcel e of + AppE (AppE (VarE drn) (LitE (IntegerL i))) list | nameBase drn == "drop" -> droppy (m0j + i) list -- NB: m0j and i are both positive. + ppe -> droppy m0j ppe + where droppy i e = (dropE `AppE` (LitE $ IntegerL i)) `AppE` e + +constE = VarE $ mkName "const" +flipE = VarE $ mkName "flip" +plusE = VarE $ mkName "+" +dropE = VarE $ mkName "drop" +reverseE = VarE $ mkName "reverse" +lengthE = VarE $ mkName "length" +sumE = VarE $ mkName "sum" +productE = VarE $ mkName "product" +leftE = VarE $ mkName "left" +rightE = VarE $ mkName "right" +lenE = VarE $ mkName "len" +absE = VarE $ mkName "abs" + +mkIF p t f = VarE (mkName "iF") `AppE` TupE [p, t, f] +mkUncurried str es = VarE (mkName str) `AppE` TupE es +mkSUBST4 = mkUncurried "sUBSTITUTE" +mkVarOp e1 op e2 = InfixE (Just e1) (VarE $ mkName op) (Just e2) + +char7 = VarE (mkName "char") `AppE` LitE (IntegerL 7) +lit0 = LitE (IntegerL 0) +lit1 = LitE (IntegerL 1) + +procSucc n (AppE (VarE name) e) | nameBase name == "succ" = procSucc (n+1) e +procSucc n (LitE (CharL c)) = LitE $ CharL $ iterate succ c `genericIndex` n +procSucc n (LitE (IntegerL i)) = LitE $ IntegerL $ n+i +procSucc n (LitE (RationalL r)) = LitE $ RationalL $ fromInteger n + r +procSucc n e | succOnlyForNumbers = InfixE (Just $ LitE $ IntegerL n) (VarE $ mkName "+") (Just $ ppExcel e) -- This is OK, if we use succ only for numbers. + | otherwise = iterate (AppE (VarE $ mkName "succ")) (ppExcel e) `genericIndex` n + + + +nrnds = repeat 5 + + + +mkPgExcel :: IO ProgGenSF +mkPgExcel = mkPGXOpts mkTrieOptSFIO options{tv0=True,nrands=repeat 20,timeout=Just 100000} [] [] excel [[],[],[]] +mkPgExcels :: Int -> IO ProgGenSF +mkPgExcels sz = mkPGXOpts mkTrieOptSFIO options{memoCondPure = \t d -> size t < sz && 0) = (/=) + +-- doubleCls = $(p [| (eq :: Equivalence Double) |]) + +excel = [$(p [| (" " :: [Char], "," :: [Char], "-" :: [Char], + fromIntegral :: Int -> Double, floor :: Double -> Int, -- These two are hidden by ppExcel. + 0::Int, 1::Int, (1+)::Int->Int, 3::Int, + 0::Double, 1::Double, -- (1+)::Double->Double, + (<) :: Int -> Int -> Bool, (<=) :: Int -> Int -> Bool, (<>) :: Int -> Int -> Bool, + (<) :: Double -> Double -> Bool, -- (<=) :: Double -> Double -> Bool, (<>) :: Double -> Double -> Bool, + (<>) :: [Char] -> [Char] -> Bool, + not :: (->) Bool Bool, True :: Bool, False :: Bool, aND'2 :: (->) Bool ((->) Bool Bool), oR'2 :: (->) Bool ((->) Bool Bool), iF'3 :: (->) Bool (a -> a -> a), + (,) :: a -> b -> (a,b), (,,) :: a -> b -> c -> (a,b,c), (,,,) :: a -> b -> c -> d -> (a,b,c,d)) |]) + ++ $(p [| ( + upper::[Char]->[Char], + lower::[Char]->[Char], + proper::[Char]->[Char], + left1 :: [Char] -> [Char], + right1 :: [Char] -> [Char], + left'2 :: [Char] -> Int -> [Char], + right'2 :: [Char] -> Int -> [Char], + dropLeft :: [Char] -> Int -> [Char], + mid'3 :: [Char] -> Int -> Int -> [Char], + len :: (->) [Char] Int, + concatenate'2 :: (->) [Char] ([Char] -> [Char]), + concatenatE'3 :: (->) [Char] ([Char] -> [Char] -> [Char]), + concatenaTE'4 :: (->) [Char] ([Char] -> [Char] -> [Char] -> [Char]), + concatenATE'5 :: (->) [Char] ([Char] -> [Char] -> [Char] -> [Char] -> [Char]), + concateNATE'6 :: (->) [Char] ([Char] -> [Char] -> [Char] -> [Char] -> [Char] -> [Char]), + {- + sum :: [Double] -> Double, + product :: [Double] -> Double, + max :: [Double] -> Double, + min :: [Double] -> Double, + average :: [Double] -> Double, + count :: [Double] -> Double, + sumif :: [Maybe Double] -> Double, +-} + flip cEILING'2 . abs :: Double -> (->) Double Double, + fLOOR0 :: (->) Double (Double -> Double), + rOUND'2 :: (->) Double (Int -> Double), + roundup'2 :: (->) Double (Int -> Double), + rounddown'2 :: (->) Double (Int -> Double), + trim::[Char]->[Char], + fIND'3 :: [Char] -> [Char] -> Int -> Maybe Int, + ifERROR'2 :: Maybe a -> a -> a, + fact :: Int -> Maybe Int, + combin'2 :: Int -> Int -> Maybe Int, + mOD'2 :: Int -> Int -> Maybe Int, + degrees :: Double -> Double, + radians :: Double -> Double, + findIx :: [Char] -> [Char] -> Int -> Int, + sUBsTITUTE'3 :: [Char] -> [Char] -> [Char] -> [Char], + sUBST4 :: [Char] -> [Char] -> [Char] -> Int -> [Char], + countStr :: [Char] -> [Char] -> Int, + negate :: Int -> Int, + abs :: Int -> Int, + (+) :: (->) Int ((->) Int Int), + (-) :: Int -> Int -> Int, + (*) :: Int -> Int -> Int, + 10 :: Double, + 100 :: Double, + 1000 :: Double, + negate :: Double -> Double, + abs :: Double -> Double, + sign :: Double -> Double, +-- recip :: Double -> Double, -- (1/) だけど、まあ(/)と1で作れるし、いらんやろ。 + (+) :: (->) Double ((->) Double Double), + (-) :: Double -> Double -> Double, + (*) :: Double -> Double -> Double, + (/) :: Double -> Double -> Double, -- 本当はエラー処理すべし。 +-- fromIntegral :: Int -> Double, + pI () :: Double + ) |]), + $(p [| ( + exp :: Double -> Double, + ln :: Double -> Maybe Double, + sQRT :: Double -> Maybe Double, + power'2 :: Double -> Double -> Maybe Double, + lOG'2 :: Double -> Double -> Maybe Double, + sin :: Double -> Double, + cos :: Double -> Double, + tan :: Double -> Double, + asin :: Double -> Double, -- この辺もエラー処理せんと。 + acos :: Double -> Double, + atan :: Double -> Double, + sinh :: Double -> Double, + cosh :: Double -> Double, + tanh :: Double -> Double, + asinh :: Double -> Double, + acosh :: Double -> Double, + atanh :: Double -> Double, + -- floatDigits :: Double -> Int, + -- exponent :: Double -> Int, + -- significand :: Double -> Double, + -- scaleFloat :: Int -> Double -> Double, + aTAN2'2 :: Double -> Double -> Double + ) |]), + [] ] diff --git a/MagicHaskeller/LibExcelStaged.hs b/MagicHaskeller/LibExcelStaged.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/LibExcelStaged.hs @@ -0,0 +1,179 @@ +module MagicHaskeller.LibExcelStaged where +import MagicHaskeller +import Data.List +import Data.Char +import Prelude hiding (gcd) + +import MagicHaskeller.LibExcelStagedStaged + +default (Int, Integer, Double) + +-- gcd in the latest library is total, but with older versions gcd 0 0 causes an error. +gcd x y = gcd' (abs x) (abs y) + where gcd' a 0 = a + gcd' a b = gcd' b (a `rem` b) + + + + +curry2 = curry +curry3 :: ((a,b,c) -> d) -> a->b->c->d +curry3 f x y z = f(x,y,z) +curry4 :: ((a,b,c,d) -> e) -> a->b->c->d->e +curry4 f w x y z = f(w,x,y,z) +curry5 :: ((a,b,c,d,e) -> f) -> a->b->c->d->e->f +curry5 f v w x y z = f(v,w,x,y,z) +curry6 :: ((a,b,c,d,e,f) -> g) -> a->b->c->d->e->f->g +curry6 f u v w x y z = f(u,v,w,x,y,z) + +{- +The Policy: +1. During synthesis, monomorphic types including Int and Double must be used by mkTrie &c. +2. fromIntegral and floor are available when synthesizing, but they are removed by ppExcel. +3. Because of 2., functions must be defined polymorphically here, or the generation of input-output examples by the CGI would cause type mismatch. +-} + +iF :: (Bool, a, a) -> a +iF (True, t, f) = t +iF (False, t, f) = f +upper = map toUpper +lower = map toLower +{- This definition unnecessarily trims the spaces. +proper = unwords . map proper' . words +proper' "" = "" +proper' (h:ts) = toUpper h : map toLower ts +-} +-- I think the following definition is enough. PROPER capitalizes letters even after a hyphen or an apostrophe. +proper "" = "" +proper (c:cs) | isAlpha c = toUpper c : case span isAlpha cs of (ts, ds) -> map toLower ts ++ proper ds + | otherwise = c : proper cs + +right, left :: RealFrac a => ([b], a) -> [b] +left1 = take 1 +right1 str = right (str, 1) +left (b, a) = take (Prelude.round a) b +right (b, a) = reverse (take (Prelude.round a) (reverse b)) +dropLeft b a = right(b, len(b) - a) +mid (c, a, b) = take (Prelude.round b) (drop (Prelude.round a - 1) c) +len :: Num a => String -> a +len = fromIntegral . length +concatenate (a, b) = a ++ b +concatenatE (a,b,c) = a++b++c +concatenaTE (a,b,c,d) = a++b++c++d +concatenATE (a,b,c,d,e) = a++b++c++d++e +concateNATE (a,b,c,d,e,f) = a++b++c++d++e++f + + +{- +max = maximum +min= minimum +average= \a -> Prelude.sum a / fromIntegral (length a) +count= \a -> length (filter (/= 0) a) +sumif ms = Prelude.sum[x|Just x <- ms] +-} +cEILING, fLOOR, mround :: (Double, Double) -> Double +cEILING (_, 0) = 0 +cEILING (a, b) = fromIntegral (Prelude.ceiling (a / b))*b +mround (_, 0) = 0 +mround (a, b) = fromIntegral (Prelude.round (a / b))*b +-- http://office.microsoft.com/en-us/excel-help/mround-HP005209185.aspx?CTT=5&origin=HP005204211 + +-- As for FLOOR, FLOOR(0,0) is 0, but FLOOR(x,0) is #DIV/0 for other x's. Also, if the second argument is negative, the result is $NUM. +-- Thus, we should prepare something different, defining \a b -> IF(b > 0, FLOOR(a,b), 0). +-- The postprocessor expands it to FLOOR(a,b) if b is known to be positive. +fLOOR0 a b | b <= 0 = 0 + | otherwise = fromIntegral (Prelude.floor (a / b))*b + +-- We need fLOOR in order to generate I/O examples. This definition is not exact, but it alerts anyway if its second argument is not positive. +fLOOR (0, 0) = 0 +fLOOR (a, b) | b <= 0 = 0/0 + | otherwise = fLOOR0 a b + +-- これらの第２引数は切り捨てで整数にされるみたい。なので、**ではなく^^を用いなければならない。 +rOUND, roundup, rounddown :: RealFrac a => (Double, a) -> Double +rOUND (a, b) = mround (a, 0.1 ^^ floor b) +roundup (a, b) | a > 0 = cEILING (a, 0.1 ^^ floor b) + | otherwise = fLOOR0 a (0.1 ^^ floor b) +rounddown (a, b) | a < 0 = cEILING (a, 0.1 ^^ floor b) + | otherwise = fLOOR0 a (0.1 ^^ floor b) + +trim = unwords . words +fIND :: (RealFrac a, Num b) => (String, String, a) -> Maybe b +fIND (pat, xs, pos) = fmap (fromIntegral . fst) $ Data.List.find (isPrefixOf pat . snd) $ zip [1..] $ drop (truncate pos-1) $ tails xs +ifERROR :: (Maybe a, a) -> a +ifERROR (mb, x) = maybe x id mb +aND (a, b) = a && b +oR (a, b) = a || b +sign :: Num a => a -> a +sign = signum +power (a,b) | isNaN result || isInfinite result = Nothing + | otherwise = Just result + where result = a ** b +sQRT x | x < 0 = Nothing + | otherwise = Just $ sqrt x +lOG(a,b) | a<=0 || b<=0 = Nothing + | otherwise = Just $ logBase b a +ln a | a <= 0 = Nothing + | otherwise = Just $ Prelude.log a +pI () = pi +aTAN2 (x,y) = atan2 y x + +fact n | n < 0 = Nothing + | otherwise = Just $ product [1..n] +combin (n,r) | (signum n + 1) * (signum r + 1) * (signum (r-n) + 1) == 0 = Nothing + | otherwise = Just $ product [n-r+1 .. n] / product [1..r] + +mOD :: (RealFrac a, RealFrac b, Num c) => (a, b) -> Maybe c +mOD(_,0) = Nothing +mOD(m,n) = Just $ fromInteger $ truncate m `mod` truncate n +degrees = ((180/pi)*) +radians = ((pi/180)*) + + +gCD (m, n) = gcd (truncate m) (truncate n) + +findIx c xs n = finD(char(7), sUBSTITUTE(concatenate(c,xs), c, char(7), 1+abs(n)))-1 +finD(c, xs) = maybe undefined id $ fIND(c, xs, 1) +char = (:"") . chr + + +sUBsTITUTE :: (String, String, String) -> String +sUBsTITUTE(ts, "", _) = ts -- 実際やってみたらこうだった． +sUBsTITUTE([], _, _) = [] +sUBsTITUTE(text@(t:ts), old, new) = case old `stripPrefix` text of Nothing -> t : sUBsTITUTE(ts, old, new) + Just rest -> new ++ sUBsTITUTE(rest, old, new) + +sUBSTITUTE :: RealFrac a => (String, String, String, a) -> String +sUBSTITUTE(text, old, new, num) | num <= 0 = error "#NUM" + | otherwise = if null old then text + else sUB text old new (floor num) +sUB "" _ _ _ = "" +sUB text@(t:ts) old new n = case old `stripPrefix` text of Nothing -> t : sUB ts old new n + Just rest | n<=1 -> new ++ rest + | otherwise -> old ++ sUB rest old new (n-1) + +sUBST4 :: RealFrac a => String -> String -> String -> a -> String +sUBST4 text old new num = sUBSTITUTE(text, old, new, 1+abs(num)) + +countStr :: Num a => String -> String -> a +countStr x "" = 0 +countStr x str = fromIntegral $ (length(x)-length(sUBsTITUTE(x,str,""))) `div` length (str) +$(mkCurriedDecls "'2" [|curry2|] [|(left,right,concatenate,cEILING,mround,rOUND,roundup,rounddown,ifERROR,aND,oR,power,lOG,aTAN2,combin,mOD,gCD)|]) +{- The above should generate: +left'2 = curry2 left +right'2 = curry2 right +... +-} + +$(mkCurriedDecls "'3" [|curry3|] [|(iF,mid,fIND,sUBsTITUTE,concatenatE)|]) +{- again, +iF'3 = curry3 iF +mid'3 = curry3 mid +... +-} + +$(mkCurriedDecls "'4" [|curry4|] [|concatenaTE|]) + +$(mkCurriedDecls "'5" [|curry5|] [|concatenATE|]) + +$(mkCurriedDecls "'6" [|curry6|] [|concateNATE|]) diff --git a/MagicHaskeller/LibExcelStagedStaged.hs b/MagicHaskeller/LibExcelStagedStaged.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/LibExcelStagedStaged.hs @@ -0,0 +1,14 @@ +-- This module can be included LibExcelStaged when using GHC-7.8, but cannot when using 7.6. +module MagicHaskeller.LibExcelStagedStaged where +import Data.Ratio(numerator, denominator) + +instance RealFrac Int where + properFraction x = (fromIntegral x,0) + truncate = fromIntegral + round = fromIntegral + ceiling = fromIntegral + floor = fromIntegral + +instance Fractional Int where -- This is necessary because Fractional is a superclass of RealFrac + (/) = div + fromRational r = fromIntegral (numerator r) `div` fromIntegral (denominator r) diff --git a/MagicHaskeller/LibTH.hs b/MagicHaskeller/LibTH.hs --- a/MagicHaskeller/LibTH.hs +++ b/MagicHaskeller/LibTH.hs @@ -5,32 +5,59 @@ -- For previous versions, try: -- darcs get http://nautilus.cs.miyazaki-u.ac.jp/~skata/ somedirectoryname -- and retrieve an older version via some darcs command. -{-# OPTIONS -XTemplateHaskell -XNoMonomorphismRestriction -fglasgow-exts #-} +{-# OPTIONS -XTemplateHaskell -XNoMonomorphismRestriction -cpp #-} module MagicHaskeller.LibTH(module MagicHaskeller.LibTH, module MagicHaskeller) where import MagicHaskeller +import MagicHaskeller.Types(size) +#ifdef TFRANDOM +import System.Random.TF(seedTFGen) +#else import System.Random(mkStdGen) +#endif import Control.Monad(liftM2) -import Data.List hiding (tail, init) +import Data.List hiding (tail) import Data.Char import Data.Maybe +-- import Data.Ratio +import MagicHaskeller.FastRatio import qualified Data.Generics as G -import Prelude hiding (tail, init, gcd) +import MagicHaskeller.ProgGenSF(mkTrieOptSFIO) + +import qualified Data.IntMap as IM +import Data.Hashable + +import Prelude hiding (tail, gcd, enumFromThenTo) + +-- whether succ is used only for numbers or not +succOnlyForNumbers = False -- This is False, because we now use succ :: Char->Char. + -- total variants of prelude functions +last' = (\x xs -> last (x:xs)) tail = drop 1 -init xs = zipWith const xs (drop 1 xs) +-- init xs = zipWith const xs (drop 1 xs) -- gcd in the latest library is total, but with older versions gcd 0 0 causes an error. gcd x y = gcd' (abs x) (abs y) where gcd' a 0 = a gcd' a b = gcd' b (a `rem` b) +-- This definition does not work correctly for Fractional numbers. +-- Maybe @[l,m..n]@ could be used for other cases than 'EQ' even if the original enumFromThenTo is hidden. YMMV, though. +enumFromThenTo l m n = map toEnum $ + case compare lint mint of + EQ -> error "MagicHaskeller.LibTH.enumFromThenTo m m n" + LT -> takeWhile (<=nint) $ iterate (+(mint-lint)) lint + GT -> takeWhile (>=nint) $ iterate (+(mint-lint)) lint + where lint = fromEnum l + mint = fromEnum m + nint = fromEnum n initialize, init075, inittv1 :: IO () -initialize = do setPrimitives (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |])) +initialize = do setPrimitives [] (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| hd :: (->) [a] (Maybe a) |]) ++ plusInt ++ plusInteger) setDepth 10 -- MagicHaskeller version 0.8 ignores the setDepth value and always memoizes. -init075 = do setPG $ mkMemo075 (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| ((+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |] )) +init075 = do setPG $ mkMemo075 [] (list ++ nat ++ natural ++ mb ++ bool ++ plusInt ++ plusInteger) setDepth 10 -- The @tv1@ option prevents type variable @a@ in @forall a. E1(a) -> E2(a) -> ... -> En(a) -> a@ from matching n-ary functions where n>=2. @@ -38,7 +65,8 @@ -- because @forall a b c. E1(a->b->c) -> E2(a->b->c) -> ... -> En(a->b->c) -> a -> b -> c@ and @forall a b c. E1((a,b)->c) -> E2((a,b)->c) -> ... -> En((a,b)->c) -> (a,b) -> c@ are isomorphic, and thus the latter can always be used instead of the former. inittv1 = do setPG $ mkPGOpt (options{primopt = Nothing, tv1 = True}) - (list ++ nat ++ natural ++ mb ++ bool ++ tuple ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |] )) + [] + (list ++ nat ++ natural ++ mb ++ bool ++ tuple ++ $(p [| (hd :: (->) [a] (Maybe a)) |]) ++ plusInt ++ plusInteger ) setDepth 10 tuple = $(p [| ((,) :: a -> b -> (a,b), uncurry :: (a->b->c) -> (->) (a,b) c) |]) @@ -46,15 +74,15 @@ -- Specialized memoization tables. Choose one for quicker results. mall, mlist, mlist', mnat, mlistnat, mnat_nc, mnatural, mlistnatural :: ProgramGenerator pg => pg -mall = mkPG (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |])) +mall = mkPG (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| hd :: (->) [a] (Maybe a) |]) ++ plusInt ++ plusInteger) mlist = mkPG list mlist' = mkPG list' -mnat = mkPG (nat ++ $(p [| (+) :: Int -> Int -> Int |])) -mnatural = mkPG (natural ++ $(p [| (+) :: Integer -> Integer -> Integer |])) -mlistnat = mkPG (list ++ nat ++ $(p [| (+) :: Int -> Int -> Int |])) -mlistnatural = mkPG (list ++ natural ++ $(p [| (+) :: Integer -> Integer -> Integer |])) +mnat = mkPG (nat ++ plusInt) +mnatural = mkPG (natural ++ plusInteger) +mlistnat = mkPG (list ++ nat ++ plusInt) +mlistnatural = mkPG (list ++ natural ++ plusInteger) -mnat_nc = mkMemo (nat ++ $(p [| (+) :: Int -> Int -> Int |])) +mnat_nc = mkMemo (nat ++ plusInt) hd :: [a] -> Maybe a hd [] = Nothing @@ -70,15 +98,17 @@ -- Gamma |- A -- This is just for the efficiency reason, and one can use the infixed form, i.e., maybe :: a -> (b->a) -> Maybe b -> a, if efficiency does not matter. In fact, this info is ignored if both 'guess' and 'constrL' options are False. -mb, mb', nat, natural, nat', nat'woPred, natural', list'', list', list, bool, boolean, eq, intinst, list1, list1', list2, list3, list3', nats, tuple, tuple', rich, rich', debug :: [Primitive] +mb, mb', nat, natural, nat', nat'woPred, natural', plusInt, plusInteger, list'', list', list, bool, boolean, intinst, list1, list1', list2, list3, list3', nats, tuple, tuple', rich, rich', debug :: [Primitive] mb = $(p [| ( Nothing :: Maybe a, Just :: a -> Maybe a, maybe :: a -> (b->a) -> (->) (Maybe b) a ) |] ) mb' = $(p [| ( Nothing :: Maybe a, Just :: a -> Maybe a, flip . maybe :: a -> (->) (Maybe b) ((b->a) -> a) ) |] ) -nat = $(p [| (0 :: Int, succ :: Int->Int, nat_para :: (->) Int (a -> (Int -> a -> a) -> a)) |] ) -natural = $(p [| (0 :: Integer, succ :: Integer->Integer, nat_para :: (->) Integer (a -> (Integer -> a -> a) -> a)) |] ) -nat' = $(p [| (0 :: Int, succ :: Int->Int, nat_cata :: (->) Int (a -> (a -> a) -> a), pred :: Int->Int) |] ) -nat'woPred = $(p [| (0 :: Int, succ :: Int->Int, nat_cata :: (->) Int (a -> (a -> a) -> a)) |] ) -natural' = $(p [| (0 :: Integer, succ :: Integer->Integer, nat_cata :: (->) Integer (a -> (a -> a) -> a), pred :: Integer->Integer) |] ) +nat = $(p [| (0 :: Int, (1+) :: Int->Int, nat_para :: (->) Int (a -> (Int -> a -> a) -> a)) |] ) +natural = $(p [| (0 :: Integer, (1+) :: Integer->Integer, nat_para :: (->) Integer (a -> (Integer -> a -> a) -> a)) |] ) +nat' = $(p [| (0 :: Int, (1+) :: Int->Int, nat_cata :: (->) Int (a -> (a -> a) -> a), pred :: Int->Int) |] ) +nat'woPred = $(p [| (0 :: Int, (1+) :: Int->Int, nat_cata :: (->) Int (a -> (a -> a) -> a)) |] ) +natural' = $(p [| (0 :: Integer, (1+) :: Integer->Integer, nat_cata :: (->) Integer (a -> (a -> a) -> a), pred :: Integer->Integer) |] ) +plusInt = $(p [| (+) :: (->) Int ((->) Int Int) |]) +plusInteger = $(p [| (+) :: (->) Integer ((->) Integer Integer) |]) -- Nat paramorphism nat_para :: Integral i => i -> a -> (i -> a -> a) -> a @@ -93,9 +123,9 @@ where nc 0 = x nc i = f (nc (i-1)) -list'' = $(p [| ([], (:), flip . flip foldr :: a -> (->) [b] ((b -> a -> a) -> a), tail :: [a] -> [a]) |] ) -- foldr's argument order makes the synthesis slower:) -list' = $(p [| ([], (:), foldr :: (b -> a -> a) -> a -> (->) [b] a, tail :: [a] -> [a]) |] ) -- foldr's argument order makes the synthesis slower:) -list = $(p [| ([], (:), list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a)) |] ) +list'' = $(p [| ([] :: [a], (:), flip . flip foldr :: a -> (->) [b] ((b -> a -> a) -> a), tail :: (->) [a] [a]) |] ) -- foldr's argument order makes the synthesis slower:) +list' = $(p [| ([] :: [a], (:), foldr :: (b -> a -> a) -> a -> (->) [b] a, tail :: (->) [a] [a]) |] ) -- foldr's argument order makes the synthesis slower:) +list = $(p [| ([] :: [a], (:), list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a)) |] ) -- List paramorphism list_para :: [b] -> a -> (b -> [b] -> a -> a) -> a @@ -111,7 +141,10 @@ -- | 'postprocess' replaces uncommon functions like catamorphisms with well-known functions. postprocess :: Exp -> Exp postprocess (AppE (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) e5) | nameBase name == "." = postprocess $ ((e1 `AppE` (e2 `AppE` e3)) `AppE` e4) `AppE` e5 -- ad hoc pattern:S --- postprocess (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) | nameBase name == "flip" = postprocess $ ((e1 `AppE` e3) `AppE` e2) `AppE` e4 +postprocess (AppE (AppE (AppE (AppE (ConE name) e1) e2) e3) e4) | nameBase name == "(,,,)" = postprocess $ TupE [e1, e2, e3, e4] +postprocess (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) | nameBase name == "flip" = postprocess $ ((e1 `AppE` e3) `AppE` e2) `AppE` e4 +postprocess (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) | nameBase name == "." = postprocess $ e1 `AppE` (e2 `AppE` e3) +postprocess (AppE (e@(AppE (AppE (ConE name) p) t)) f) | nameBase name == "(,,)" = postprocess $ TupE [p,t,f] postprocess (AppE (e@(AppE (AppE (VarE name) p) t)) f) = case nameBase name of "iF" -> CondE ppp ppt ppf @@ -120,29 +153,48 @@ (VarE (mkName "!!")) -- Should I use genericIndex instead of (!!) also here? (Just $ case ppp of LitE (IntegerL i) -> LitE $ IntegerL $ abs i _ -> VarE (mkName "abs") `AppE` ppp) - "flip" -> postprocess $ - case ppp of VarE nm -> (VarE (mkName $ nameBase nm) `AppE` ppf) `AppE` ppt -- can't recall why, but the name needs to be unqualified - _ -> (ppp `AppE` ppf) `AppE` ppt + "flip" -> postprocess $ (ppp `AppE` ppf) `AppE` ppt "." -> postprocess (p `AppE` (t `AppE` f)) _ -> postprocess e `AppE` ppf where ppp = postprocess p ppt = postprocess t ppf = postprocess f - +postprocess (AppE f@(AppE (ConE name) lj) e) | nameBase name == "(,)" = postprocess $ TupE [lj, e] postprocess (AppE f@(AppE (VarE name) lj) e) = case nameBase name of "drop" -> case pplj of LitE (IntegerL j) | j<=0 -> ppe | j> 0 -> ppdrop j e _ -> (dropE `AppE` pplj) `AppE` ppe "enumFromTo" -> ArithSeqE $ FromToR pplj ppe + "last'" -> case ppe of AppE (VarE rev) e' | nameBase rev == "reverse" -> ((VarE (mkName "foldr") `AppE` constE) `AppE` pplj) `AppE` e' -- last (x : reverse xs) ==> foldr const x xs + _ -> VarE (mkName "last") `AppE` InfixE (Just pplj) (ConE $ mkName ":") (Just ppe) + "filter" -> case ppe of AppE (VarE rev) e' | nameBase rev == "reverse" -> reverseE `AppE` ((VarE (mkName "filter") `AppE` pplj) `AppE` e') -- filter p (reverse xs) ==> reverse (filter p xs) This is useful in the case of (reverse . drop 1 . reverse) (filter p ((reverse . drop 1 . reverse) xs)). Also, there can be a case of last' x (filter p ((reverse . drop 1 . reverse) xs)) + _ -> (VarE (mkName "filter") `AppE` pplj) `AppE` ppe _ -> postprocess f `AppE` ppe where pplj = postprocess lj ppe = postprocess e +postprocess (AppE (InfixE m@(Just _) op Nothing) e) = postprocess (InfixE m op (Just e)) +postprocess (AppE (InfixE Nothing op m@(Just _)) e) = postprocess (InfixE (Just e) op m) postprocess (AppE v@(VarE name) e) - = case nameBase name of + = case nameBase name of +-- 'b':'y':'1':'_':nm -> VarE $ mkName$ by1 nm "tail" -> ppdrop 1 e "negate" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ (-i) LitE (RationalL r) -> LitE $ RationalL $ (-r) _ -> AppE v ppe + "abs" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ abs i + LitE (RationalL r) -> LitE $ RationalL $ abs r + _ -> AppE (ppv v) ppe + "floor" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL i + LitE (RationalL r) -> LitE $ IntegerL $ floor r + _ -> AppE v ppe + "round" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL i + LitE (RationalL r) -> LitE $ IntegerL $ round r + _ -> AppE v ppe + "ceiling" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL i + LitE (RationalL r) -> LitE $ IntegerL $ ceiling r + _ -> AppE v ppe + "fromIntegral" -> case ppe of LitE i -> LitE i + _ -> AppE v ppe "succ" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ succ i LitE (RationalL r) -> LitE $ RationalL $ succ r @@ -150,23 +202,50 @@ InfixE (Just (LitE (IntegerL n))) (VarE nm) (Just e) | nameBase nm == "+" -> InfixE (Just $ LitE $ IntegerL $ succ n) plusE (Just e) AppE (VarE nm) e - | nameBase nm == "succ" -> InfixE (Just $ LitE $ IntegerL 2) plusE (Just e) -- This is OK, if we use succ only for numbers. + | succOnlyForNumbers && + nameBase nm == "succ" -> InfixE (Just $ LitE $ IntegerL 2) plusE (Just e) -- This is OK, if we use succ only for numbers. _ -> AppE (ppv v) ppe - _ -> AppE (ppv v) ppe + "reverse" -> case ppe of + LitE (StringL xs) -> LitE $ StringL $ reverse xs + ListE es -> ListE $ reverse $ map postprocess es + ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> ArithSeqE $ FromThenToR (LitE $ IntegerL t) (LitE $ IntegerL $ t-1) (LitE $ IntegerL f) + AppE (VarE name) e' | nameBase name == "reverse" -> e' + _ -> AppE reverseE ppe + "length" -> case ppe of + LitE (StringL xs) -> LitE $ IntegerL $ toInteger $ length xs + ListE es -> LitE $ IntegerL $ toInteger $ length es + ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> LitE $ IntegerL $ t - f + 1 -- can be bottom, if t is less than f. + AppE (VarE name) e' | nameBase name == "reverse" -> AppE lengthE e' -- length . reverse => length + -- There can also be the length . map f => length rule. The length . map f pattern can appear when f includes some absent argument. + _ -> AppE lengthE ppe + "sum" -> case ppe of + AppE (VarE name) e' | nameBase name == "reverse" -> AppE sumE e' + _ -> AppE sumE ppe + "product" -> case ppe of + AppE (VarE name) e' | nameBase name == "reverse" -> AppE productE e' + _ -> AppE productE ppe + nb -> case IM.lookup (hash nb) byMap of Just fun -> fun ppe $ AppE (ppv v) ppe + Nothing -> AppE (ppv v) ppe where ppe = postprocess e -- The following pattern is actually unnecessary if only eta-long normal expressions will be generated. postprocess e@(VarE _) = ppv e postprocess (AppE f x) = postprocess f `AppE` postprocess x -postprocess (InfixE me1 op me2) = case (j1,op,j2) of - (Just (LitE (IntegerL i1)), VarE opname, Just (LitE (IntegerL i2))) -> +postprocess (InfixE me1 op me2) + = let j1 = fmap postprocess me1 + j2 = fmap postprocess me2 + in case op of + VarE opname -> + case (j1,j2) of + (Just (LitE (IntegerL i1)), Just (LitE (IntegerL i2))) -> case nameBase opname of "+" -> LitE $ IntegerL $ i1+i2 "-" -> LitE $ IntegerL $ i1-i2 "*" -> LitE $ IntegerL $ i1*i2 _ -> theDefault - _ -> theDefault - where j1 = fmap postprocess me1 - j2 = fmap postprocess me2 - theDefault = InfixE j1 op j2 + (Just (LitE (IntegerL i1)), Just (InfixE (Just (LitE (IntegerL i2))) (VarE inopn) me3)) + | nameBase opname == "+" && nameBase inopn `elem` ["+","-"] -> InfixE (Just $ LitE $ IntegerL $ i1+i2) (VarE $ ppopn inopn) me3 + _ -> theDefault + where theDefault = InfixE j1 (VarE $ ppopn opname) j2 + ConE opname -> InfixE j1 (ConE $ ppopn opname) j2 postprocess (LamE pats e) = ppLambda pats (postprocess e) @@ -175,15 +254,35 @@ postprocess (SigE e ty) = postprocess e `SigE` ty postprocess e = e -shown `appearsIn` e = G.everything (||) (False `G.mkQ` (\name -> show (name::Name) == shown)) e +byMap = IM.fromList $ byEqs++byOrds +byEqs = (hash "deleteFirstsBy", skipEq "\\\\") : [ (hash $ xs++"By", skipEq xs) | xs <- ["nub","delete","union","intersect","group"]] +byOrds = [ (hash $ xs++"By", skipOrd xs) | xs <- ["sort","insert","minimum","maximum"]] +skip op namestr = \eqExp wholeExp -> case eqExp of VarE name | nameBase name == op -> VarE $ mkName namestr + _ -> wholeExp +skipEq = skip "==" +skipOrd = skip "compare" +shown `appearsIn` e = G.everything (||) (False `G.mkQ` (\name -> show (name::Name) == shown)) e +{- +by1 "le" = "<=" +by1 "less" = "<" +by1 name = name +-} + -- ¤³¤ÎÊÕ¤ÏCoreLang¤Ç¤ä¤ë¤Ù¤­¤È¤¤¤¦µ¤¤â¡¥¾¯¤Ê¤¯¤È¤â¡¤¤½¤Ã¤Á¤Ç´Ø¿ô¤òÄêµÁ¤¹¤Ù¤­¡¥ -- \x -> iF foo bar x ¤Î¾ì¹ç¤âÀè¤Ë¦Ç´ÊÌ󤵤ì¤Æ¤·¤Þ¤¦¤È¥¤¥Þ¥¤¥Á¤Ç¤Ï¤¢¤ë¡¥¤Î¤Ç¡¤¦Ç´ÊÌó¤ÏiF, nat_cata, tail¤Ê¤É¤Î½èÍý¤Î¸å¤Ë¤ä¤ë¡¥ -- For readability, we apply eta-reduction only when we can fully eta-reduce at the outermost lambda-abstraction. ppLambda [VarP n] (AppE e (VarE n')) | shown == show n' && not (shown `appearsIn` e) = e where shown = show n +ppLambda [VarP n, VarP m, VarP l] (AppE (AppE (AppE e (VarE n')) (VarE m')) (VarE l')) + | shown == show n' && showm == show m' && showl == show l' && free = e + | shown == show m' && showm == show n' && showl == show l' && free = flipE `AppE` e + where shown = show n + showm = show m + showl = show l + free = not (shown `appearsIn` e) && not (showm `appearsIn` e) && not (showl `appearsIn` e) ppLambda [VarP n, VarP m] (AppE (AppE e (VarE n')) (VarE m')) | shown == show n' && showm == show m' && free = e | shown == show m' && showm == show n' && free = flipE `AppE` e @@ -213,11 +312,17 @@ ppv e@(VarE name) | nameBase name `elem` ["iF", "nat_cata"] = LamE [ VarP n | n <- names ] (postprocess (AppE (AppE (AppE e p) t) f)) - | otherwise = e + | nameBase name == "last'" = LamE [ VarP n | n <- tail names ] (postprocess (AppE (AppE e t) f)) + | otherwise = VarE $ ppopn name where names = [ mkName [n] | n <- "ptf" ] [p,t,f] = map VarE names +ppopn name = case nameModule name of Just mod | -- mod `elem` ["GHC.Base", "GHC.List", "GHC.Char", "GHC.Num"] -- Rather, optional qualifications such as Data.Map. and Data.Text. should be qualified, and all other qualifications should be removed. + not $ mod `elem` ["Data.Map", "Data.Set", "Data.Text", "Data.ByteString"] -- These are just examples for now. + -> mkName $ nameBase name + _ -> name + ppdrop m0j e = case postprocess e of AppE (AppE (VarE drn) (LitE (IntegerL i))) list | nameBase drn == "drop" -> droppy (m0j + i) list -- NB: m0j and i are both positive. @@ -228,12 +333,17 @@ flipE = VarE $ mkName "flip" plusE = VarE $ mkName "+" dropE = VarE $ mkName "drop" +reverseE = VarE $ mkName "reverse" +lengthE = VarE $ mkName "length" +sumE = VarE $ mkName "sum" +productE = VarE $ mkName "product" procSucc n (AppE (VarE name) e) | nameBase name == "succ" = procSucc (n+1) e procSucc n (LitE (CharL c)) = LitE $ CharL $ iterate succ c `genericIndex` n procSucc n (LitE (IntegerL i)) = LitE $ IntegerL $ n+i procSucc n (LitE (RationalL r)) = LitE $ RationalL $ fromInteger n + r -procSucc n e = InfixE (Just $ LitE $ IntegerL n) (VarE $ mkName "+") (Just $ postprocess e) -- This is OK, if we use succ only for numbers. +procSucc n e | succOnlyForNumbers = InfixE (Just $ LitE $ IntegerL n) (VarE $ mkName "+") (Just $ postprocess e) -- This is OK, if we use succ only for numbers. + | otherwise = iterate (AppE (VarE $ mkName "succ")) (postprocess e) `genericIndex` n postprocessQ :: Exp -> ExpQ {- This type of patterns is not available yet. @@ -261,12 +371,15 @@ postprocessQ e = return e -exploit :: (Typeable a, Filtrable a) => (a -> Bool) -> IO () -exploit pred = filterThenF pred (everything (reallyall::ProgGenSF)) >>= pprs +exploit :: (Typeable a, Filtrable a) => + Bool -- ^ whether to include functions with unused arguments + -> (a -> Bool) -> IO () +exploit withAbsents pred = filterThenF pred (everything (reallyall::ProgGenSF) withAbsents) >>= pprs -boolean = $(p [| ((&&) :: Bool -> Bool -> Bool, - (||) :: Bool -> Bool -> Bool, - not :: Bool -> Bool) |] ) +boolean = $(p [| ((&&) :: (->) Bool ((->) Bool Bool), + (||) :: (->) Bool ((->) Bool Bool), + not :: (->) Bool Bool) |] ) +{- -- Type classes are not supported yet.... -- Without tuning of the probability distribution over Chars and Lists, these are almost useless. eq = $(p [| ((==) :: Int->Int->Bool, (/=) :: Int->Int->Bool, @@ -281,26 +394,168 @@ (==) :: Char->Char->Bool, (/=) :: Char->Char->Bool, (==) :: Bool->Bool->Bool, (/=) :: Bool->Bool->Bool) |]) -} +-} +newtype Partial a = Part {undef :: a} +undefs = map (\[a,b] -> (a,b)) $ + [-- Bool や Orderingのように、ありがちな値を返してしまうものは、採用すべきでない。$(p [| (Part False :: Partial Bool, undefined :: Partial Bool) |]), $(p [| (Part EQ :: Partial Ordering, undefined :: Partial Ordering) |]), + $(p [| (Part 53 :: Partial Int, undefined :: Partial Int) |]), + $(p [| (Part '\29' :: Partial Char, undefined :: Partial Char) |]), + $(p [| (Part [43] :: Partial [Int], undefined :: Partial [Int]) |]), + $(p [| (Part "wleajkf" :: Partial [Char], undefined :: Partial [Char]) |])] +by1_head :: Partial a -> [a] -> a +by1_head (Part u) [] = u +by1_head _ (x:_) = x +(--#!!) :: Partial a -> [a] -> Int -> a +(--#!!) (Part u) [] n = u +(--#!!) (Part u) (x:xs) n + = case compare n 0 of + LT -> u + EQ -> x + GT -> (--#!!) (Part u) xs (n-1) + +prelPartial = $(p [| ( by1_head :: Partial a -> (->) [a] a, + (--#!!) :: Partial a -> [a] -> (->) Int a) |] ) + +newtype Equivalence a = Eq {(--#==) :: a -> a -> Bool} +eq = Eq (==) +by1_eqMaybe :: Equivalence a -> Equivalence (Maybe a) +by1_eqMaybe (Eq op) = Eq $ eqMaybeBy op +eqMaybeBy _ Nothing Nothing = True +eqMaybeBy _ Nothing (Just _) = False +eqMaybeBy _ (Just _) Nothing = False +eqMaybeBy e (Just x) (Just y) = e x y +by1_eqList :: Equivalence a -> Equivalence [a] +by1_eqList (Eq e) = Eq $ eqListBy e +eqListBy _ [] [] = True +eqListBy _ [] _ = False +eqListBy _ _ [] = False +eqListBy e (x:xs) (y:ys) = e x y && eqListBy e xs ys + +by2_eqEither :: Equivalence a -> Equivalence b -> Equivalence (Either a b) +by2_eqEither (Eq e1) (Eq e2) = Eq $ eqEitherBy e1 e2 +eqEitherBy e1 _ (Left x) (Left y) = e1 x y +eqEitherBy _ _ (Left _) (Right _) = False +eqEitherBy _ _ (Right _) (Left _) = False +eqEitherBy _ e2 (Right x) (Right y) = e2 x y +by2_eqPair :: Equivalence a -> Equivalence b -> Equivalence (a,b) +by2_eqPair (Eq e1) (Eq e2) = Eq $ eqPairBy e1 e2 +eqPairBy e1 e2 (x,y) (z,w) = e1 x z && e2 y w + +eqs = $(p [| (eq :: Equivalence Bool, eq :: Equivalence Ordering, eq :: Equivalence Int, eq :: Equivalence Char, -- eq :: Equivalence (Ratio Int) is defined in ratioCls + eq :: Equivalence [Int], eq :: Equivalence [Char], by1_eqMaybe :: Equivalence a -> Equivalence (Maybe a), by1_eqList :: Equivalence a -> Equivalence [a], + by2_eqEither :: Equivalence a -> Equivalence b -> Equivalence (Either a b), by2_eqPair :: Equivalence a -> Equivalence b -> Equivalence (a,b)) |]) +prelEqRelated = [$(p [| ((--#==) :: Equivalence a -> (->) a (a -> Bool), (--#/=) :: Equivalence a -> (->) a (a -> Bool)) |]), + $(p [| by1_elem :: Equivalence a -> a -> [a] -> Bool |]), + []] +dataListEqRelated = [[], + $(p [| (by1_group :: Equivalence a -> [a] -> [[a]], + by1_nub :: Equivalence a -> [a] -> [a]) |]), + $(p [| (by1_isPrefixOf :: Equivalence a -> [a] -> [a] -> Bool, + by1_isSuffixOf :: Equivalence a -> [a] -> [a] -> Bool, + by1_isInfixOf :: Equivalence a -> [a] -> [a] -> Bool, + by1_stripPrefix :: Equivalence a -> [a] -> [a] -> Maybe [a], + by1_lookup :: Equivalence a -> a -> (->) [(a, b)] (Maybe b) + ) |])] + +(--#/=) :: Equivalence a -> a -> a -> Bool +(--#/=) (Eq e) x y = not $ e x y +by1_elem :: Equivalence a -> a -> [a] -> Bool +by1_elem (Eq e) k = any (e k) +by1_group :: Equivalence a -> [a] -> [[a]] +by1_group (Eq e) = groupBy e +by1_nub :: Equivalence a -> [a] -> [a] +by1_nub (Eq e) = nubBy e +by1_isPrefixOf :: Equivalence a -> [a] -> [a] -> Bool +by1_isPrefixOf _ [] _ = True +by1_isPrefixOf _ _ [] = False +by1_isPrefixOf e@(Eq op) (x:xs) (y:ys) = op x y && by1_isPrefixOf e xs ys +by1_isSuffixOf :: Equivalence a -> [a] -> [a] -> Bool +by1_isSuffixOf e xs ys = by1_isPrefixOf e (reverse xs) (reverse ys) +by1_isInfixOf :: Equivalence a -> [a] -> [a] -> Bool +by1_isInfixOf e xs ys = any (by1_isPrefixOf e xs) (tails ys) +by1_stripPrefix :: Equivalence a -> [a] -> [a] -> Maybe [a] +by1_stripPrefix eq [] ys = Just ys +by1_stripPrefix eq@(Eq op) (x:xs) (y:ys) | op x y = by1_stripPrefix eq xs ys +by1_stripPrefix _ _ _ = Nothing +by1_lookup :: Equivalence a -> a -> (->) [(a, b)] (Maybe b) +by1_lookup _ _ [] = Nothing +by1_lookup eq@(Eq op) key ((x,y):xys) + | op key x = Just y + | otherwise = by1_lookup eq key xys + +newtype Ordered a = Ord {by1_compare :: a->a->Ordering} +cmp = Ord compare +by1_cmpMaybe :: Ordered a -> Ordered (Maybe a) +by1_cmpMaybe (Ord compare) = Ord $ compareMaybeBy compare +compareMaybeBy _ Nothing Nothing = EQ +compareMaybeBy _ Nothing (Just _) = LT +compareMaybeBy _ (Just _) Nothing = GT +compareMaybeBy compare (Just x) (Just y) = compare x y +by1_cmpList :: Ordered a -> Ordered [a] +by1_cmpList (Ord compare) = Ord $ compareListBy compare +compareListBy _ [] [] = EQ +compareListBy _ [] _ = LT +compareListBy _ _ [] = GT +compareListBy compare (x:xs) (y:ys) = case compare x y of EQ -> compareListBy compare xs ys + o -> o +by2_cmpEither :: Ordered a -> Ordered b -> Ordered (Either a b) +by2_cmpEither (Ord compare1) (Ord compare2) = Ord $ compareEitherBy compare1 compare2 +compareEitherBy compare1 _ (Left x) (Left y) = compare1 x y +compareEitherBy _ _ (Left _) (Right _) = LT +compareEitherBy _ _ (Right _) (Left _) = GT +compareEitherBy _ compare2 (Right x) (Right y) = compare2 x y +by2_cmpPair :: Ordered a -> Ordered b -> Ordered (a, b) +by2_cmpPair (Ord compare1) (Ord compare2) = Ord $ comparePairBy compare1 compare2 +comparePairBy compare1 compare2 (x,y) (z,w) = case compare1 x z of EQ -> compare2 y w + o -> o +ords = $(p [| (cmp :: Ordered Bool, cmp :: Ordered Ordering, -- なぜかcomment outされていたので復活させてみた。問題あるなら戻すが。 + cmp :: Ordered Int, cmp :: Ordered Char, -- cmp :: Ordered (Ratio Int) is defined in ratioCls + by1_cmpMaybe :: Ordered a -> Ordered (Maybe a), by1_cmpList :: Ordered a -> Ordered [a], + by2_cmpEither :: Ordered a -> Ordered b -> Ordered (Either a b), by2_cmpPair :: Ordered a -> Ordered b -> Ordered (a,b)) |]) +prelOrdRelated = [$(p [| by1_compare :: Ordered a -> a->a->Ordering |]) ++ + $(p [| ((--#<=) :: Ordered a -> a -> a -> Bool, (--#<) :: Ordered a -> a -> a -> Bool, + by1_max :: Ordered a -> (->) a (a->a), by1_min :: Ordered a -> (->) a (a->a)) |] ), [], + []] + -- maximum_by :: Ordered a -> [a] -> a, minimum_by :: Ordered a -> [a] -> a) |]) -- Those are not total. +dataListOrdRelated = [[],[],$(p [| by1_sort :: Ordered a -> [a] -> [a] |] )] + +(--#<=) (Ord compare) x y = case compare x y of GT -> False + _ -> True +(--#<) (Ord compare) x y = case compare x y of LT -> True + _ -> False +by1_max c x y = if (--#<=) c x y then y else x +by1_min c x y = if (--#<=) c x y then x else y +by1_sort (Ord compare) = sortBy compare + intinst = intinst1++intinst2 -intinst1 = $(p [| ( (<=) :: Int->Int->Bool, +intinst1 = $(p [| ( + {- + (<=) :: Int->Int->Bool, (<) :: Int->Int->Bool, -- (>=) :: Int->Int->Bool, -- (>) :: Int->Int->Bool, max :: Int->Int->Int, min :: Int->Int->Int, +-} (-) :: Int->Int->Int, - (*) :: Int->Int->Int, - div :: Int->Int->Int, - mod :: Int->Int->Int, - (^) :: Int->Int->Int) |]) + (*) :: Int->Int->Int -- , + -- div :: Int->Int->Int, + -- mod :: Int->Int->Int, + -- (^) :: Int->Int->Int + ) |]) +intpartials = $(p [| ( + div :: Int->Int->Int, + mod :: Int->Int->Int, + (^) :: Int->Int->Int + ) |]) intinst2 = $(p [| ( gcd :: Int->Int->Int, lcm :: Int->Int->Int) |]) list1 = $(p [| (map :: (a -> b) -> (->) [a] [b], - (++) :: [a] -> [a] -> [a], + (++) :: (->) [a] ([a] -> [a]), filter :: (a -> Bool) -> [a] -> [a], - concat :: [[a]] -> [a], + concat :: (->) [[a]] [a], concatMap :: (a -> [b]) -> (->) [a] [b], length :: (->) [a] Int, replicate :: Int -> a -> [a], @@ -309,9 +564,9 @@ takeWhile :: (a -> Bool) -> [a] -> [a], dropWhile :: (a -> Bool) -> [a] -> [a]) |] ) list1' = $(p [| (flip map :: (->) [a] ((a -> b) -> [b]), - (++) :: [a] -> [a] -> [a], + (++) :: (->) [a] ([a] -> [a]), filter :: (a -> Bool) -> [a] -> [a], - concat :: [[a]] -> [a], + concat :: (->) [[a]] [a], flip concatMap :: (->) [a] ((a -> [b]) -> [b]), length :: (->) [a] Int, replicate :: Int -> a -> [a], @@ -326,14 +581,14 @@ unwords :: [[Char]] -> [Char] ) |] ) list3 = $(p [| (reverse :: [a] -> [a], - and :: [Bool] -> Bool, - or :: [Bool] -> Bool, + and :: (->) [Bool] Bool, + or :: (->) [Bool] Bool, any :: (a -> Bool) -> (->) [a] Bool, all :: (a -> Bool) -> (->) [a] Bool, zipWith :: (a->b->c) -> (->) [a] ((->) [b] [c]) ) |] ) list3' = $(p [| (reverse :: [a] -> [a], - and :: [Bool] -> Bool, - or :: [Bool] -> Bool, + and :: (->) [Bool] Bool, + or :: (->) [Bool] Bool, flip any :: (->) [a] ((a -> Bool) -> Bool), flip all :: (->) [a] ((a -> Bool) -> Bool), flip . flip zipWith :: (->) [a] ((->) [b] ((a->b->c) -> [c])) ) |] ) @@ -348,11 +603,17 @@ -- comment out (mkStdGen 123456) when using 0.8.3* +#ifdef TFRANDOM +generator = seedTFGen (3497676378205993723,16020016691208771845,6545968067796471226,2770936286170065919) +#else +generator = mkStdGen 123456 +#endif -- Currently only the pg==ConstrLSF case makes sense. mix, poormix :: ProgramGenerator pg => pg -mix = mkPGSF (mkStdGen 123456) +mix = mkPGSF generator nrnds + [] (list++bool) rich @@ -360,13 +621,14 @@ -- Still, having both cons and tail is OK. soso = (list'' ++ nat'woPred ++ - mb' ++ bool ++ $(p [| (+) :: Int -> Int -> Int |]) ++ -- x $(p [| (hd :: [a] -> Maybe a, (+) :: Int -> Int -> Int) |]) ++ - boolean ++ eq ++ intinst1 ++ + mb' ++ bool ++ plusInt ++ -- x $(p [| (hd :: [a] -> Maybe a, (+) :: Int -> Int -> Int) |]) ++ + boolean ++ intinst1 ++ list1' ++ list3') rich = soso ++ list2 ++ intinst2 ++ $(p [| init :: [a] -> [a] |]) -poormix = mkPGSF (mkStdGen 123456) +poormix = mkPGSF generator nrnds + [] $(p [| ([] :: [a], True) |] ) rich @@ -377,8 +639,9 @@ list1 ++ list3) mx :: ProgramGenerator pg => pg -mx = mkPGSF (mkStdGen 123456) +mx = mkPGSF generator nrnds + [] (list++bool) rich' @@ -386,25 +649,209 @@ -- Library used by the program server backend pgfull :: ProgGenSF --- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until :: (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ eq ++ intinst) -- rich とあまり変わらない． -pgfull = mkPGXOpt options{tv1=True,nrands=repeat 20} $ foldr (zipWith (++)) literals [fromPrelude, fromDataList, fromDataChar, fromDataMaybe] -literals = [$(p [|(1::Int, ' '::Char)|]),[],[]] -fromPrelude = [soso ++ $(p [| (abs :: Int->Int, compare :: Char->Char->Ordering, compare :: Int->Int->Ordering, foldr const :: a -> [a] -> a, - flip (flip . either) :: (->) (Either a b) ((a -> c) -> (b -> c) -> c)) |]), - list2 ++ $(p [| (scanl :: (a -> b -> a) -> a -> [b] -> [a], scanr :: (a -> b -> b) -> b -> [a] -> [b], scanl1 :: (a -> a -> a) -> [a] -> [a], scanr1 :: (a -> a -> a) -> [a] -> [a], replicate :: Int -> a -> [a], sum :: [Int]->Int, product :: [Int]->Int, +-- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until :: (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ intinst) -- rich とあまり変わらない． +pgfull = mkPGXOpt options{tv1=True,nrands=repeat 20,timeout=Just 100000} (eqs++ords) clspartialss full tupartialssNormal +-- A pgfull must be a CAF, so we must have pgfulls and access pgfullSized via pgfulls. Directly calling pgfullSized is heap-inefficient. +pgfulls :: [ProgGenSF] +pgfulls = map pgfullSized [0..] + where pgfullSized sz = mkPGXOpt options{memoCondPure = \t d -> size t < sz && 0 [a], enumFromTo :: Int -> Int -> [Int], 1::Int, product :: [Int] -> Int, concatMap :: (a -> [b]) -> [a] -> [b]) |]), [],[]] + +pgfullIO :: IO ProgGenSFIORef +pgfullIO = mkPGXOptIO options{tv1=True,nrands=repeat 20} (eqs++ords) clspartialss full tupartialssNormal +full = foldr zipAppend literals [fromPrelude, prelEqRelated, dataListEqRelated, prelOrdRelated, dataListOrdRelated, fromDataList, fromDataChar, fromDataMaybe] +clspartialss :: [(Primitive,Primitive)] +clspartialss = undefs +tupartialss, tupartialssNormal :: [[(Primitive,Primitive)]] +tupartialss + = map (map (\[a,b] -> (a,b))) + [ [], -- [$(p [|(reverse . drop 1 . reverse :: [a] -> [a], init :: [a] -> [a])|])], -- An unnatural value cannot be returned in this case due to the polymorphism, unless the Partial class is used. + [$(p [| (chr . (`mod` 65536) . abs, chr . abs) |]), + $(p [| (chr . (`mod` 65536) . succ . ord :: Char->Char, succ :: Char -> Char) |])], + [$(p [| ((\m n -> if n==0 then 83 else div m n) :: Int->Int->Int, div :: Int->Int->Int) |]), + $(p [| ((\m n -> if n==0 then 46 else mod m n) :: Int->Int->Int, mod :: Int->Int->Int) |]), + $(p [| ((\m n -> if n<0 then 23 else m ^ n) :: Int->Int->Int, (^) :: Int->Int->Int) |]), + $(p [| ((\l m n -> if l==m then [n,m,m,n,m,n,n] else [l,m..n]) :: Int->Int->Int->[Int], enumFromThenTo :: Int->Int->Int->[Int]) |]), + $(p [| ((\l m n -> if l==m then [m,n,n,m,n,n,n,m] else [l,m..n]) :: Char->Char->Char->[Char], enumFromThenTo :: Char->Char->Char->[Char]) |]), + $(p [| (chr . (`mod` 65536) . pred . ord :: Char->Char, pred :: Char -> Char) |]) + ] ] +-- tupartialssNormal is a variant of tupartialss, which make total functions from partial functions by making the latter return `natural' values for error cases. +-- Returning natural values is good if MagicHaskeller.fpartial try total versions after failures of partial versions, and currently that is the case. +tupartialssNormal + = map (map (\[a,b] -> (a,b))) + [ [], -- [$(p [|(reverse . drop 1 . reverse :: [a] -> [a], init :: [a] -> [a])|])], + [$(p [| (chr . (`mod` 65536) . abs, chr . abs) |]), + $(p [| (chr . (`mod` 65536) . succ . ord :: Char->Char, succ :: Char -> Char) |])], + [$(p [| ((\m n -> if n==0 then 0 else div m n) :: Int->Int->Int, div :: Int->Int->Int) |]), + $(p [| ((\m n -> if n==0 then 0 else mod m n) :: Int->Int->Int, mod :: Int->Int->Int) |]), + $(p [| ((\m n -> if m==0 then 0 else m ^ n) :: Int->Int->Int, (^) :: Int->Int->Int) |]), + $(p [| ((\l m n -> if l==m then [] else [l,m..n]) :: Int->Int->Int->[Int], enumFromThenTo :: Int->Int->Int->[Int]) |]), + $(p [| ((\l m n -> if l==m then [] else [l,m..n]) :: Char->Char->Char->[Char], enumFromThenTo :: Char->Char->Char->[Char]) |]), + $(p [| (chr . (`mod` 65536) . pred . ord :: Char->Char, pred :: Char -> Char) |]) + ] ] + +literals = [$(p [|(1::Int, 2::Int, 3::Int, ' '::Char)|]), [], []] +fromPrelude = [ -- prelPartial ++ + soso ++ $(p [| (null :: (->) [a] Bool, -- Without this, null is synthesized as all (\_ -> False). + abs :: (->) Int Int, -- compare :: Char->Char->Ordering, compare :: Int->Int->Ordering, + flip . flip foldl :: a -> (->) [b] ((a -> b -> a) -> a), + foldr const :: a -> (->) [a] a, + last' :: a -> [a] -> a, + reverse . drop 1 . reverse :: [a] -> [a], + enumFromTo :: Int->Int->[Int], enumFromTo :: Char->Char->[Char], + fmap :: (a -> b) -> (->) (Maybe a) (Maybe b), + flip (flip . either) :: (->) (Either a b) ((a -> c) -> (b -> c) -> c)) |]) + ++ intinst2 ++ $(p [| (sum :: (->) [Int] Int, product :: (->) [Int] Int) |]), + list2 ++ $(p [| (scanl :: (a -> b -> a) -> a -> [b] -> [a], scanr :: (a -> b -> b) -> b -> [a] -> [b], scanl1 :: (a -> a -> a) -> [a] -> [a], scanr1 :: (a -> a -> a) -> [a] -> [a], -- until :: (a -> Bool) -> (a -> a) -> a -> a) を入れてたが，どうもuntilがあると急に遅くなる．その割に，全く使われない．何じゃらホイ - enumFromTo :: Int->Int->[Int], show :: Int -> String) |])++ $(p [| flip uncurry :: (->) (a,b) ((a->b->c) -> c) |]), - intinst2 ++ $(p [| ((,) :: a -> b -> (a,b), Left :: a -> Either a b, Right :: b -> Either a b) |])] -- , enumFromThenTo :: Int->Int->Int->[Int]) |])] -- The problem is that enumFromThenTo 1 1 2 is infinite. -fromDataList = [$(p [| (sortBy, nubBy, deleteBy, transpose, stripPrefix :: String->String->Maybe String)|]), + show :: Int -> [Char]) |])++ $(p [| ((,) :: a -> b -> (a,b), flip uncurry :: (->) (a,b) ((a->b->c) -> c)) |]), + $(p [| ((,,) :: a -> b -> c -> (a,b,c), Left :: a -> Either a b, Right :: b -> Either a b, + zip :: (->) [a] ((->) [b] [(a, b)]), + zip3 :: (->) [a] ((->) [b] ((->) [c] [(a, b, c)])), + unzip :: (->) [(a, b)] ([a], [b]), + unzip3 :: (->) [(a, b, c)] ([a], [b], [c]), + odd :: Int -> Bool, even :: Int -> Bool) |]) + ] -- My version of enumFromThenTo is used. The problem of the library version is that enumFromThenTo 1 1 2 is infinite. +fromDataList = [$(p [| (sortBy, nubBy, deleteBy, dropWhileEnd, transpose -- , stripPrefix :: [Char]->[Char]->Maybe [Char], + )|]), $(p [| ( - find, flip findIndex :: (->) [a] ((a -> Bool) -> Maybe Int), flip findIndices :: (->) [a] ((a -> Bool) -> [Int]), deleteFirstsBy, unionBy, intersectBy, groupBy, insertBy, maximumBy, minimumBy) |]), - $(p [| (intersperse, subsequences, permutations, -- dropWhileEnd, - inits, tails, - isPrefixOf :: String -> String -> Bool, isSuffixOf :: String -> String -> Bool, isInfixOf :: String -> String -> Bool + find, flip findIndex :: (->) [a] ((a -> Bool) -> Maybe Int), flip findIndices :: (->) [a] ((a -> Bool) -> [Int]), deleteFirstsBy, unionBy :: (a -> a -> Bool) -> (->) [a] ([a] -> [a]), intersectBy :: (a -> a -> Bool) -> (->) [a] ([a] -> [a]), groupBy, insertBy -- , maximumBy, minimumBy + ) |]), + $(p [| (intersperse, subsequences, permutations, + inits, tails, + flip . flip mapAccumL :: acc -> (->) [x] ((acc -> x -> (acc, y)) -> (acc, [y])), + flip . flip mapAccumR :: acc -> (->) [x] ((acc -> x -> (acc, y)) -> (acc, [y])) + + -- , isPrefixOf :: [Char] -> [Char] -> Bool, isSuffixOf :: [Char] -> [Char] -> Bool, isInfixOf :: [Char] -> [Char] -> Bool ) |])] -fromDataChar = [$(p [| (toUpper, toLower) |]), - $(p [| (ord, chr, digitToInt, intToDigit, isControl, isSpace, isLower, isUpper, isAlpha, isAlphaNum, isDigit) |]), - $(p [| (isPrint, isOctDigit, isHexDigit) |])] +fromDataChar = [$(p [| (toUpper :: (->) Char Char, toLower :: (->) Char Char) |])++ + $(p [| (ord, isControl :: (->) Char Bool, isSpace :: (->) Char Bool, isLower :: (->) Char Bool, isUpper :: (->) Char Bool, isAlpha :: (->) Char Bool, isAlphaNum :: (->) Char Bool, isDigit :: (->) Char Bool, isSymbol :: (->) Char Bool, isPunctuation :: (->) Char Bool, isPrint :: (->) Char Bool) |]), + $(p [| (isOctDigit :: (->) Char Bool, isHexDigit :: (->) Char Bool) |]), + []] fromDataMaybe = [[], - $(p [| (catMaybes, listToMaybe, maybeToList) |])] + $(p [| (catMaybes, listToMaybe :: (->) [a] (Maybe a), maybeToList :: (->) (Maybe a) [a]) |]), + []] -- mapMaybe f = catMaybes . map f + +pgWithDoubleRatio :: ProgGenSF +pgWithDoubleRatio = mkPGXOpt options{tv1=True,nrands=repeat 20,timeout=Just 100000} (eqs++ords++doubleCls++ratioCls) clspartialss withDoubleRatio tupartialssNormal +pgWithDoubleRatios :: [ProgGenSF] +pgWithDoubleRatios = map pgWithDoubleRatioSized [0..] + where pgWithDoubleRatioSized sz = mkPGXOpt options{memoCondPure = \t d -> size t < sz && 0 size t < sz && 0 size t < sz && 0 Ratio Int, + negate :: Ratio Int -> Ratio Int, + abs :: Ratio Int -> Ratio Int, + sum :: (->) [Ratio Int] (Ratio Int), + product :: (->) [Ratio Int] (Ratio Int), + (+) :: Ratio Int -> Ratio Int -> Ratio Int, + (-) :: Ratio Int -> Ratio Int -> Ratio Int, + (*) :: Ratio Int -> Ratio Int -> Ratio Int, + (/) :: Ratio Int -> Ratio Int -> Ratio Int, + fromIntegral :: Int -> Ratio Int, + properFraction :: (->) (Ratio Int) (Int, Ratio Int), + round :: (->) (Ratio Int) Int, + floor :: (->) (Ratio Int) Int, + ceiling :: (->) (Ratio Int) Int, + (^^) :: Ratio Int -> Int -> Ratio Int) |]), + [], + [] ] +fromDataRatio = [ + $(p [| ((%) :: Int -> Int -> Ratio Int, + numerator :: (->) (Ratio Int) Int, + denominator :: (->) (Ratio Int) Int) |]), + [], [] ] + +pgWithDouble :: ProgGenSF +pgWithDouble = mkPGXOpt options{tv1=True,nrands=repeat 20,timeout=Just 100000} (eqs++ords++doubleCls) clspartialss withDouble tupartialssNormal +pgWithDoubles :: [ProgGenSF] +pgWithDoubles = map pgWithDoubleSized [0..] + where pgWithDoubleSized sz = mkPGXOpt options{memoCondPure = \t d -> size t < sz && 0 Double, + negate :: Double -> Double, + abs :: Double -> Double, + signum :: Double -> Double, + recip :: Double -> Double, + sum :: (->) [Double] Double, + product :: (->) [Double] Double, + (+) :: Double -> Double -> Double, + (-) :: Double -> Double -> Double, + (*) :: Double -> Double -> Double, + (/) :: Double -> Double -> Double, + fromIntegral :: Int -> Double, + properFraction :: (->) Double (Int, Double), + round :: (->) Double Int, + floor :: (->) Double Int, + ceiling :: (->) Double Int, + truncate :: (->) Double Int, + (^^) :: Double -> Int -> Double, + pi :: Double + ) |]), + $(p [| ( + exp :: Double -> Double, + log :: Double -> Double, + sqrt :: Double -> Double, + (**) :: Double -> Double -> Double, + logBase :: Double -> Double -> Double, + sin :: Double -> Double, + cos :: Double -> Double, + tan :: Double -> Double, + asin :: Double -> Double, + acos :: Double -> Double, + atan :: Double -> Double, + sinh :: Double -> Double, + cosh :: Double -> Double, + tanh :: Double -> Double, + asinh :: Double -> Double, + acosh :: Double -> Double, + atanh :: Double -> Double, + floatDigits :: Double -> Int, + exponent :: Double -> Int, + significand :: Double -> Double, + scaleFloat :: Int -> Double -> Double, + atan2 :: Double -> Double -> Double + ) |]), + [] ] diff --git a/MagicHaskeller/MHTH.lhs b/MagicHaskeller/MHTH.lhs --- a/MagicHaskeller/MHTH.lhs +++ b/MagicHaskeller/MHTH.lhs @@ -15,7 +15,6 @@ import MagicHaskeller.ReadTHType(showTypeName, plainTV, unPlainTV) - #ifdef __GLASGOW_HASKELL__ nameToNameStr :: (Name -> String) -> Name -> ExpQ nameToNameStr shw name = return $ LitE (StringL (shw name)) diff --git a/MagicHaskeller/MemoToFiles.hs b/MagicHaskeller/MemoToFiles.hs --- a/MagicHaskeller/MemoToFiles.hs +++ b/MagicHaskeller/MemoToFiles.hs @@ -25,10 +25,10 @@ -- in toMemo $ mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ unPS ps emptySubst (mxty+1) in mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ fps mxty ps -- in toMemo $ mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty)) $ fps mxty ps -fps :: Search m => Int -> PriorSubsts m es -> m (es,[(Int, Type)],Int) +fps :: Search m => TyVar -> PriorSubsts m es -> m (es,[(TyVar, Type)],TyVar) fps mxty (PS f) = do (exprs, sub, m) <- f emptySubst (mxty+1) return (exprs, filterSubst sub mxty, m) - where filterSubst :: Subst -> Int -> [(Int, Type)] + where filterSubst :: Subst -> TyVar -> [(TyVar, Type)] filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. -- ¤³¤ì¤Ã¤ÆProgGen¸ÂÄ꤫ diff --git a/MagicHaskeller/Minimal.hs b/MagicHaskeller/Minimal.hs --- a/MagicHaskeller/Minimal.hs +++ b/MagicHaskeller/Minimal.hs @@ -1,12 +1,43 @@ +{-# LANGUAGE CPP #-} -- minimal set of definitions for safer use by a server -module MagicHaskeller.Minimal(f1E, f1EF, ProgGenSF) where +module MagicHaskeller.Minimal(e, f1E, f1EF, f1EIO, f1EFIO, ProgGenSF, NearEq((~=)), postprocess, ppExcel) where import MagicHaskeller.LibTH +import MagicHaskeller.LibExcel import MagicHaskeller.ProgGenSF +import MagicHaskeller.ProgramGenerator import Data.Typeable +import MagicHaskeller.NearEq(NearEq((~=))) +import Language.Haskell.TH(Exp) -deadline = Just 20000 +import MagicHaskeller.DebMT(interleaveActions) +#ifdef PAR +import Control.Monad.Par.IO +import Control.Monad.IO.Class(liftIO) +#endif -f1E :: Typeable a => (a -> Bool) -> ProgGenSF -> [[Exp]] -f1E pred = map (map (postprocess . fst)) . map (fp deadline pred) . everything -f1EF :: (Filtrable a, Typeable a) => (a -> Bool) -> ProgGenSF -> [[Exp]] -f1EF pred = map (map (postprocess . fst)) . everyF deadline . map (fp deadline pred) . everything +-- deadline = Just 20000 -- `timeout $ opt $ extractCommon pgsf' is used instead. + +f1E :: Typeable a => (Exp->Exp) -> (a -> Bool) -> ProgGenSF -> Bool -> [[Exp]] +f1E postproc pred pgsf withAbsents = let o = opt $ extractCommon pgsf in map (map (postproc . fst)) $ map (fpartial (timeout o) pred) $ etup undefined pgsf withAbsents +f1EF :: (Filtrable a, Typeable a) => (Exp->Exp) -> (a -> Bool) -> ProgGenSF -> Bool -> [[Exp]] +f1EF postproc pred pgsf withAbsents = let o = opt $ extractCommon pgsf in map (map (postproc . fst)) $ everyF o $ map (fpartial (timeout o) pred) $ etup undefined pgsf withAbsents + + +e :: Typeable a => (Exp->Exp) -> a -> ProgGenSF -> Bool -> [[Exp]] +e postproc dmy pgsf withAbsents = let o = opt $ extractCommon pgsf in map (map (postproc . fst . fst))$ etup dmy pgsf withAbsents + +f1EIO :: Typeable a => (Exp->Exp) -> (a -> Bool) -> ProgGenSF -> Bool -> IO [[Exp]] +f1EIO postproc pred pgsf withAbsents + = let o = opt $ extractCommon pgsf + in fmap (map (map (postproc . fst))) $ interleaveActions $ map (fpartialIO (timeout o) pred) $ etup undefined pgsf withAbsents +-- in fmap (map (map (postproc . fst)) . concat) $ interleaveActions $ map (mapIO $ fpartialIO (timeout o) pred) $ chopN 2 $ etup undefined pgsf withAbsents +chopN n xs = map (take n) $ iterate (drop n) xs -- e.g. chopN 2 ['a'..] == ["ab","cd", .... + +-- in fmap (map (map (postproc . fst))) $ mapIO (fpartialIO (timeout o) pred) $ etup undefined pgsf withAbsents +-- in fmap (map (map (postproc . fst))) $ runParIO $ mapParIO (fpartialParIO (timeout o) pred) $ etup undefined pgsf withAbsents +-- in fmap (map (map (postproc . fst))) $ interleaveActions $ map (runParIO . fpartialParIO (timeout o) pred) $ etup undefined pgsf withAbsents +-- in fmap (map (map (postproc . fst))) $ runParIO $ mapParIO (liftIO . fpartialIO (timeout o) pred) $ etup undefined pgsf withAbsents +f1EFIO :: (Filtrable a, Typeable a) => (Exp->Exp) -> (a -> Bool) -> ProgGenSF -> Bool -> IO [[Exp]] +f1EFIO postproc pred pgsf withAbsents + = let o = opt $ extractCommon pgsf + in fmap (map (map (postproc . fst)) . everyF o) $ interleaveActions $ map (fpartialIO (timeout o) pred) $ etup undefined pgsf withAbsents diff --git a/MagicHaskeller/MyCheck.hs b/MagicHaskeller/MyCheck.hs --- a/MagicHaskeller/MyCheck.hs +++ b/MagicHaskeller/MyCheck.hs @@ -15,13 +15,30 @@ maybe I could import and reuse definitions of Arbitrary of QuickCheck-2. (But still I am interested in using different generator than StdGen.) -} +{-# LANGUAGE CPP #-} module MagicHaskeller.MyCheck where +#ifdef TFRANDOM +import System.Random.TF.Gen +import System.Random.TF.Instances +#else import System.Random +#endif import Control.Monad(liftM, liftM2, liftM3) import Data.Char(ord,chr) -import Data.Ratio +-- import Data.Ratio +import MagicHaskeller.FastRatio +import Prelude hiding (Rational) +-- for bit hacks. Should such stuff be in a different module? +import qualified Data.ByteString as BS +import Data.Word +import Data.Bits + +#ifdef TFRANDOM +newtype Gen a = Gen {unGen :: Int -> TFGen -> a} +#else newtype Gen a = Gen {unGen :: Int -> StdGen -> a} +#endif type Coarb a b = a -> Gen b -> Gen b sized :: (Int -> Gen a) -> Gen a @@ -64,13 +81,21 @@ arbitraryIntegral = sized $ \n -> arbitraryR ( - fromIntegral n, fromIntegral n ) -- variant of Test.QuickCheck.variant using divide-and-conquer -logvariant, newvariant :: Integral i => i -> Gen a -> Gen a +logvariant, newvariant :: (Bits i, Integral i) => i -> Gen a -> Gen a logvariant 0 = coarbitraryBool True +#ifdef TFRANDOM +logvariant n | n > 0 = coarbitraryBool False . logvariant (n `shiftR` 32) . coarbitraryBits 32 (n .&. 0xFFFFFFFF) +#else logvariant n | n > 0 = coarbitraryBool False . logvariant (n `div` 2) . coarbitraryBool (n `mod` 2 == 0) +#endif | otherwise = error "logvariant: negative argument" newvariant n | n >= 0 = coarbitraryBool True . logvariant n | otherwise = coarbitraryBool False . logvariant (-1-n) +#ifdef TFRANDOM +coarbitraryBits b n (Gen f) = Gen $ \size gen -> f size $ splitn gen b $ fromIntegral n +#endif + arbitraryFloat :: Gen Float arbitraryFloat = arbitraryRealFloat arbitraryDouble :: Gen Double @@ -89,25 +114,53 @@ coarbitraryRealFloat x = let (sig, xpo) = decodeFloat x in newvariant sig . newvariant xpo arbitraryChar = do r <- arbitraryR (0,11) - [arbNum, arbNum, arbASC, return '\n', retSpc, arbLow, arbLow, arbLow, arbLow, arbUpp, arbUpp, arbUpp] !! r + [arbNum, arbNum, arbASC, return '\n', return '\n', retSpc, retSpc, retSpc, arbLow, arbLow, arbUpp, arbUpp] !! r retSpc = return ' ' arbASC = arbitraryR (' ', chr 126) arbNum = arbitraryR ('0','9') arbLow = arbitraryR ('a','z') arbUpp = arbitraryR ('A','Z') -coarbitraryChar c = newvariant (ord c) +coarbitraryChar c = logvariant (ord c) arbitraryOrdering :: Gen Ordering arbitraryOrdering = arbitraryR (0,2) >>= return . toEnum -- Ordering is not an instance of Random! +-- For arbitraryRatio we need a type constraint anyway in order to deal with the div0 case, so we have to do something tricky. +arbitraryRatio :: (Random i, Integral i) => Gen (Ratio i) +arbitraryRatio = liftM2 (%) arbitraryIntegral (fmap (\x->1+abs x) arbitraryIntegral) + arbitraryMaybe :: Gen a -> Gen (Maybe a) arbitraryMaybe arb = do b <- arbitraryBool if b then return Nothing else liftM Just arb arbitraryList :: Gen a -> Gen [a] -arbitraryList arb = sized $ \n -> arbitraryR (0,n) >>= \n -> sequence $ replicate n arb +-- arbitraryList arb = sized $ \n -> arbitraryR (0,n) >>= \n -> sequence $ replicate n arb -- This causes examples bloat rapidly in the case of deeply-nested lists, such as [[[[[[a]]]]]]. +#ifdef TFRANDOM +arbitraryList (Gen f) = sized $ \n -> arbitraryR (0,n) >>= \i -> sequenceSized (lg i + 1) $ replicate i (Gen $ \s g -> f (max 1 (lg s * k)) g) +sequenceSized :: Int -> [Gen a] -> Gen [a] +sequenceSized bits arbs = Gen $ \n g -> zipWith (\(Gen m) g -> m n g) arbs $ map (splitn g bits) [0..] +#else +arbitraryList (Gen f) = sized $ \n -> arbitraryR (0,n) >>= \i -> sequence $ replicate i (Gen $ \s g -> f (max 1 (lg s * k)) g) +#endif +k = 1 + +-- bitvector algorithm for computing log2, translated from http://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn. +-- maybe overkill? +lg :: (Integral a, Integral b) => a -> b +lg = fromIntegral . lg' . fromIntegral +lg' :: Word32 -> Word8 +lg' v = let v2 = v .|. (v `unsafeShiftR` 1) + v4 = v2 .|. (v2 `unsafeShiftR` 2) + v8 = v4 .|. (v4 `unsafeShiftR` 4) + v16 = v8 .|. (v8 `unsafeShiftR` 8) + v32 = v16 .|. (v16 `unsafeShiftR` 16) + in multiplyDeBruijnBitPosition `BS.index` fromIntegral ((v32 * 0x07C4ACDD) `unsafeShiftR` 27) +multiplyDeBruijnBitPosition :: BS.ByteString +multiplyDeBruijnBitPosition = BS.pack [ 0, 9, 1, 10, 13, 21, 2, 29, 11, 14, 16, 18, 22, 25, 3, 30, 8, 12, 20, 28, 15, 17, 24, 7, 19, 27, 23, 6, 26, 5, 4, 31 ] + + arbitraryPair :: Gen a -> Gen b -> Gen (a,b) arbitraryPair = liftM2 (,) @@ -126,10 +179,13 @@ coarbitraryOrdering :: Coarb Ordering b +#ifdef TFRANDOM +coarbitraryOrdering = coarbitraryBits 2 . fromEnum +#else coarbitraryOrdering x = case x of LT -> coarbitraryBool True EQ -> coarbitraryBool False . coarbitraryBool True GT -> coarbitraryBool False . coarbitraryBool False - +#endif coarbitraryList :: Coarb a b -> Coarb [a] b coarbitraryList _ [] = coarbitraryBool True coarbitraryList coarb (x:xs) = coarbitraryBool False . coarb x . coarbitraryList coarb xs @@ -142,6 +198,9 @@ coarbitraryEither coarb0 _ (Left x) = coarbitraryBool True . coarb0 x coarbitraryEither _ coarb1 (Right y) = coarbitraryBool False . coarb1 y +coarbitraryRatio :: (Bits a, Integral a) => Coarb (Ratio a) b +coarbitraryRatio r = newvariant (numerator r) . logvariant (denominator r) + coarbitraryPair :: Coarb a c -> Coarb b c -> Coarb (a,b) c coarbitraryPair coarb0 coarb1 (a,b) = coarb0 a . coarb1 b @@ -234,6 +293,6 @@ coarbitrary = coarbitraryFun arbitrary coarbitrary instance (Integral i, Random i) => Arbitrary (Ratio i) where - arbitrary = liftM2 (%) arbitraryIntegral (fmap (\x->1+abs x) arbitraryIntegral) -instance (Integral i) => Coarbitrary (Ratio i) where - coarbitrary r = newvariant (numerator r) . logvariant (denominator r) + arbitrary = arbitraryRatio +instance (Integral i, Bits i) => Coarbitrary (Ratio i) where + coarbitrary = coarbitraryRatio diff --git a/MagicHaskeller/NearEq.hs b/MagicHaskeller/NearEq.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/NearEq.hs @@ -0,0 +1,50 @@ +module MagicHaskeller.NearEq where +import MagicHaskeller.FastRatio + +infix 4 ~= -- same as (==) + +-- the nearly-equal operator with pattern-matching-like behavior over NaN and Infinity. +class NearEq a where + (~=) :: a -> a -> Bool + +-- Without check with isInfinite, Infinity ~= something would always be True. Without check with signum, Infinity ~= -Infinity would always be True. +instance NearEq Double where + a ~= b = na==nb && ia == isInfinite b && signum a == signum b && (na || ia || abs (a-b) <= (scaleFloat (-24) $ abs a)) + where na = isNaN a + nb = isNaN b + ia = isInfinite a +instance NearEq Float where + a ~= b = na==nb && ia == isInfinite b && signum a == signum b && (na || ia || abs (a-b) <= (scaleFloat (-12) $ abs a)) + where na = isNaN a + nb = isNaN b + ia = isInfinite a +instance NearEq () where + x ~= y = x == y +instance NearEq Bool where + x ~= y = x == y +instance NearEq Ordering where + x ~= y = x == y +instance NearEq Char where + x ~= y = x == y +instance NearEq Int where + x ~= y = x == y +instance NearEq Integer where + x ~= y = x == y +instance (NearEq i, Integral i) => NearEq (Ratio i) where + x ~= y = numerator x ~= numerator y && denominator x ~= denominator y +instance NearEq a => NearEq [a] where + [] ~= [] = True + x:xs ~= y:ys = x ~= y && xs ~= ys + _ ~= _ = False +instance NearEq a => NearEq (Maybe a) where + Nothing ~= Nothing = True + Just x ~= Just y = x ~= y + _ ~= _ = False +instance (NearEq a, NearEq b) => NearEq (Either a b) where + Left x ~= Left y = x ~= y + Right x ~= Right y = x ~= y + _ ~= _ = False +instance (NearEq a, NearEq b) => NearEq (a,b) where + (x1,x2) ~= (y1,y2) = x1 ~= y1 && x2 ~= y2 +instance (NearEq a, NearEq b, NearEq c) => NearEq (a,b,c) where + (x1,x2,x3) ~= (y1,y2,y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 diff --git a/MagicHaskeller/Options.hs b/MagicHaskeller/Options.hs --- a/MagicHaskeller/Options.hs +++ b/MagicHaskeller/Options.hs @@ -1,10 +1,15 @@ +{-# LANGUAGE CPP #-} module MagicHaskeller.Options where +#ifdef TFRANDOM +import System.Random.TF(seedTFGen, TFGen) +#else import System.Random(mkStdGen, StdGen) +#endif import MagicHaskeller.Execute(unsafeExecute) import MagicHaskeller.MemoToFiles(MemoCond, MemoType(..)) import MagicHaskeller.CoreLang import MagicHaskeller.MyDynamic - +import MagicHaskeller.Types(Type) -- | options that limit the hypothesis space. data Opt a = Opt{ primopt :: Maybe a -- ^ Use this option if you want to use a different component library for the stage of solving the inhabitation problem. @@ -12,6 +17,7 @@ -- This option makes sense only when using *SF style generators, because otherwise the program generation is not staged. -- Using a minimal set for solving the inhabitation and a redundant library for the real program generation can be a good bet. , memodepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space). Only effective when using 'ProgGen' and unless using the 'everythingIO' family. + , memoCondPure :: Type -> Int -> Bool -- ^ This represents when to memoize. It takes the query type and the query depth, and returns @True@ if the corresponding entry should be looked up from the lazy memo table. Currently this only works for ProgGenSF. , memoCond :: MemoCond -- ^ This represents which memoization table to be used based on the query type and the search depth, when using the 'everythingIO' family. , execute :: VarLib -> CoreExpr -> Dynamic -- timeout ¤Ï¤³¤ÎÃæ¤Ç¤ä¤ë¤Ù¤­¡¥IO Dynamic¤Î¾ì¹ç¤ËunsafePerformIO¤ò2²ó¤ä¤ë¤ÈÊѤʤ³¤È¤Ë¤Ê¤ê¤½¤¦¤Ê¤Î¤Ç¡¥ , timeout :: Maybe Int -- ^ @Just ms@ sets the timeout to @ms@ microseconds. Also, my implementation of timeout also catches inevitable exceptions like stack space overflow. Note that setting timeout makes the library referentially untransparent. (But currently @Just 20000@ is the default!) Setting this option to @Nothing@ disables both timeout and capturing exceptions. @@ -84,14 +90,20 @@ -- can only be replaced with @Eval t => t@ and @Eval t => u -> t@, while if @False@ with @Eval t => t@, @Eval t => u->t@, @Eval t => u->v->t@, etc., where @Eval t@ means t cannot be replaced with a function. -- The restriction can be amended if the tuple constructor and destructors are available. , tv0 :: Bool - , stdgen :: StdGen -- ^ The random seed. - , nrands :: [Int] -- ^ number of random samples at each depth, for each type. +#ifdef TFRANDOM + , stdgen :: TFGen -- ^ The random seed. +#else + , stdgen :: StdGen -- ^ The random seed. +#endif + , nrands :: [Int] -- ^ number of random samples at each depth, for each type, for the filter applied during synthesis (used by ProgGenSF, &c.). + , fcnrand :: Int -> Int -- ^ number of random samples at each depth, for each type, for the filter applied after synthesis (used by filterThenF, &c.). } -- | default options -- -- > options = Opt{ primopt = Nothing -- > , memodepth = 10 +-- > , memoCondPure = \ _type depth -> 0 , memoCond = \ _type depth -> return $ if depth < 10 then Ram else Recompute -- > , execute = unsafeExecute -- > , timeout = Just 20000 @@ -100,13 +112,19 @@ -- > , contain = True -- > , constrL = False -- > , tv1 = False +#ifdef TFRANDOM +-- > , stdgen = seedTFGen (3497676378205993723,16020016691208771845,6545968067796471226,2770936286170065919) +#else -- > , stdgen = mkStdGen 123456 +#endif -- > , nrands = repeat 5 +-- > , fcnrand = (6+) -- > } options :: Opt a options = Opt{ primopt = Nothing , memodepth = 10 + , memoCondPure = \ _type depth -> 0 return $ if d<10 then Ram else Recompute , execute = unsafeExecute , timeout = Just 20000 @@ -117,8 +135,13 @@ , tvndelay = 1 , tv1 = False , tv0 = False +#ifdef TFRANDOM + , stdgen = seedTFGen (3497676378205993723,16020016691208771845,6545968067796471226,2770936286170065919) +#else , stdgen = mkStdGen 123456 +#endif , nrands = nrnds + , fcnrand = (6+) } -- reducer (opt,_,_,_,_) = execute opt diff --git a/MagicHaskeller/PriorSubsts.lhs b/MagicHaskeller/PriorSubsts.lhs --- a/MagicHaskeller/PriorSubsts.lhs +++ b/MagicHaskeller/PriorSubsts.lhs @@ -6,7 +6,7 @@ When I wrote this first (around 2003?) I did not know the term `Monad Transformer' and I reinvented it.... \begin{code} -{-# OPTIONS -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, FlexibleInstances #-} module MagicHaskeller.PriorSubsts where import Control.Monad @@ -46,12 +46,12 @@ delayPS (PS f) = PS g where g s i = delay (f s i) ndelayPS n (PS f) = PS g where g s i = ndelay n (f s i) -{-# SPECIALIZE convertPS :: ([(a,Subst,Int)] -> Recomp (a,Subst,Int)) -> PriorSubsts [] a -> PriorSubsts Recomp a #-} -{-# SPECIALIZE convertPS :: ([(a,Subst,Int)] -> [(a,Subst,Int)]) -> PriorSubsts [] a -> PriorSubsts [] a #-} -convertPS :: (m (a,Subst,Int) -> n (a,Subst,Int)) -> PriorSubsts m a -> PriorSubsts n a +{-# SPECIALIZE convertPS :: ([(a,Subst,TyVar)] -> Recomp (a,Subst,TyVar)) -> PriorSubsts [] a -> PriorSubsts Recomp a #-} +{-# SPECIALIZE convertPS :: ([(a,Subst,TyVar)] -> [(a,Subst,TyVar)]) -> PriorSubsts [] a -> PriorSubsts [] a #-} +convertPS :: (m (a,Subst,TyVar) -> n (b,Subst,TyVar)) -> PriorSubsts m a -> PriorSubsts n b convertPS f (PS g) = PS h where h s i = f (g s i) -newtype PriorSubsts m a = PS {unPS :: Subst -> Int -> m (a, Subst, Int)} +newtype PriorSubsts m a = PS {unPS :: Subst -> TyVar -> m (a, Subst, TyVar)} instance Monad m => Monad (PriorSubsts m) where {-# SPECIALIZE instance Monad (PriorSubsts []) #-} return x = PS (\s m -> return (x, s, m)) @@ -124,7 +124,7 @@ setSubst s1 -} -lookupSubstPS :: MonadPlus m => Int -> PriorSubsts m Type +lookupSubstPS :: MonadPlus m => TyVar -> PriorSubsts m Type lookupSubstPS tvid = do subst <- getSubst case lookupSubst subst tvid of Nothing -> mzero Just ty -> return ty @@ -133,11 +133,11 @@ {-# SPECIALIZE getSubst :: PriorSubsts [] Subst #-} getSubst :: Monad m => PriorSubsts m Subst getSubst = PS (\s i -> return (s,s,i)) -{-# SPECIALIZE getMx :: PriorSubsts [] Int #-} -getMx :: Monad m => PriorSubsts m Int +{-# SPECIALIZE getMx :: PriorSubsts [] TyVar #-} +getMx :: Monad m => PriorSubsts m TyVar getMx = PS (\s i -> return (i,s,i)) -{-# SPECIALIZE updateMx :: (Int->Int) -> PriorSubsts [] () #-} -updateMx :: Monad m => (Int->Int) -> PriorSubsts m () +{-# SPECIALIZE updateMx :: (TyVar->TyVar) -> PriorSubsts [] () #-} +updateMx :: Monad m => (TyVar->TyVar) -> PriorSubsts m () updateMx f = PS (\s i -> return ((), s, f i)) {-# SPECIALIZE unify :: Type -> Type -> PriorSubsts [] () #-} unify :: MonadPlus m => Type -> Type -> PriorSubsts m () @@ -171,7 +171,7 @@ -- | reserveTVars takes the number of requested tvIDs, reserves consecutive tvIDs, and returns the first tvID. -reserveTVars :: Monad m => Int -> PriorSubsts m Int +reserveTVars :: Monad m => TyVar -> PriorSubsts m TyVar reserveTVars n = PS (\s i -> return (i,s,i+n)) {- ¤³¤Ã¤Á¤ÎÄêµÁ¤Ë¤·¤¿¤é°¤Êò¤ß¤¿¤¤¤Ë»þ´Ö¤ò¿©¤Ã¤¿¡¥Ìõ¥ï¥«¥á reserveTVars n = do i <- getMx @@ -183,7 +183,7 @@ {- flatten :: PriorSubsts [a] -> PriorSubsts a flatten (PS sbb) = PS (\s i -> map cat $ unMx (sbb s i)) -cat :: Bag ([a], Subst, Int) -> Bag (a, Subst, Int) +cat :: Bag ([a], Subst, TyVar) -> Bag (a, Subst, TyVar) cat xs = [ (y, s, i) | (ys, s, i) <- xs, y <- ys ] -} \end{code} diff --git a/MagicHaskeller/ProgGen.lhs b/MagicHaskeller/ProgGen.lhs --- a/MagicHaskeller/ProgGen.lhs +++ b/MagicHaskeller/ProgGen.lhs @@ -2,8 +2,9 @@ -- (c) Susumu Katayama -- \begin{code} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -cpp #-} -module MagicHaskeller.ProgGen(ProgGen(PG)) where +module MagicHaskeller.ProgGen(ProgGen(PG), mkCL, ClassLib(..), mguPrograms) where import MagicHaskeller.Types import MagicHaskeller.TyConLib @@ -12,14 +13,13 @@ import MagicHaskeller.CoreLang import Control.Monad.Search.Combinatorial import MagicHaskeller.PriorSubsts -import Data.List(partition, sortBy) +import Data.List(partition, sortBy, genericLength) import Data.Ix(inRange) import MagicHaskeller.ProgramGenerator import MagicHaskeller.Options(Opt(..)) import MagicHaskeller.Classify -import System.Random(mkStdGen) import MagicHaskeller.Instantiate import MagicHaskeller.Expression @@ -35,7 +35,6 @@ import MagicHaskeller.MemoToFiles hiding (freezePS,fps) --- x #define DESTRUCTIVE traceTy _ = id -- traceTy fty = trace ("lookup "++ show fty) @@ -54,96 +53,96 @@ -- Memoization table, created from primitive components -- | The vanilla program generator corresponding to Version 0.7.* -newtype ProgGen = PG (MemoDeb CoreExpr) -- ^ internal data representation - - -mapStrTyCon :: MemoDeb CoreExpr -> Map.Map String TyCon -mapStrTyCon = fst . extractTCL . PG +newtype ProgGen = PG (MemoDeb (ClassLib CoreExpr) CoreExpr) -- ^ internal data representation +newtype ClassLib e = CL (MemoDeb (ClassLib e) e) +-- mapStrTyCon :: Search m => MemoDeb c m CoreExpr -> Map.Map String TyCon +-- mapStrTyCon = fst . extractTCL . PG -#ifdef DESTRUCTIVE -type MemoTrie a = (MapType (BFM (Possibility a)), MapType (BFM (Possibility a))) -#else type MemoTrie a = MapType (BFM (Possibility a)) -#endif -#ifdef DESTRUCTIVE -lmt (mt,_) fty = -#else lmt mt fty = -#endif traceTy fty $ lookupMT mt fty +lookupFunsShared :: (Search m) => Generator m CoreExpr -> Generator m CoreExpr +lookupFunsShared behalf memodeb@(_,mt,_,cmn) avail reqret + = let annAvails = zip [0..] avail + in PS (\subst mx -> fromRc $ Rc $ \d ->concat [ let (tn, decoder) = encode (popArgs newavails reqret) mx in map (decodeVarsPos ixs) $ map (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ unMx (lmt mt tn) !! d | annAvs <- combs (d+1) annAvails, let (ixs, newavails) = unzip annAvs ] :: [Possibility CoreExpr]) + lookupFunsPoly :: (Search m, Expression e) => Generator m e -> Generator m e -lookupFunsPoly behalf memodeb@(mt,_,cmn) avail reqret +lookupFunsPoly behalf memodeb@(_,mt,_,cmn) avail reqret = PS (\subst mx -> let (tn, decoder) = encode (popArgs avail reqret) mx in ifDepth (<= memodepth (opt cmn)) (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ fromMemo $ lmt mt tn) (unPS (behalf memodeb avail reqret) subst mx) ) +instance WithCommon ProgGen where + extractCommon (PG (_,_,_,cmn)) = cmn instance ProgramGenerator ProgGen where - mkTrie cmn tces = PG (mkTrieMD cmn tces) - unifyingPrograms ty px@(PG x) = fmap (toAnnExpr $ reducer px) $ catBags $ fmap (\ (es,_,_) -> es) $ unifyingPossibilities ty x - unifyingProgramsIO ty px@(PG x) = fmap (toAnnExpr $ reducer px) $ catBags $ fmap (\ (es,_,_) -> es) $ unifyingPossibilitiesIO ty x - extractCommon (PG (_,_,cmn)) = cmn + mkTrie cmn classes tces = mkTriePG cmn classes tces + unifyingPrograms ty (PG x@(_,_,_,cmn)) = fromRc $ fmap (toAnnExpr $ reducer cmn) $ catBags $ fmap (\ (es,_,_) -> es) $ unifyingPossibilities ty x +instance ProgramGeneratorIO ProgGen where + mkTrieIO cmn classes tces = return $ mkTriePG cmn classes tces + unifyingProgramsIO ty (PG x@(_,_,_,cmn)) = fmap (toAnnExpr $ reducer cmn) $ catBags $ fmap (\ (es,_,_) -> es) $ unifyingPossibilitiesIO ty x -unifyingPossibilities :: Search m => Type -> MemoDeb CoreExpr -> m ([CoreExpr],Subst,Int) +unifyingPossibilities :: Search m => Type -> MemoDeb (ClassLib CoreExpr) CoreExpr -> m ([CoreExpr],Subst,TyVar) unifyingPossibilities ty memodeb = unPS (mguProgs memodeb [] ty) emptySubst 0 -unifyingPossibilitiesIO :: Type -> MemoDeb CoreExpr -> RecompT IO ([CoreExpr],Subst,Int) +unifyingPossibilitiesIO :: Type -> MemoDeb (ClassLib CoreExpr) CoreExpr -> RecompT IO ([CoreExpr],Subst,TyVar) unifyingPossibilitiesIO ty memodeb = unPS (mguProgsIO memodeb [] ty) emptySubst 0 -type MemoDeb a = (MemoTrie a, ([[Prim]],[[Prim]]), Common) +type MemoDeb c a = (c, MemoTrie a, ([[Prim]],[[Prim]]), Common) -mkTrieMD :: Common -> [[Typed [CoreExpr]]] -> MemoDeb CoreExpr -mkTrieMD cmn txs - = let - memoDeb = (memoTrie, qtl, cmn) - -- memoTrie :: MemoTrie a --- monomorphic¤Ê¤Î¤Î¤ß¤òmemo¤·¤¿¤¤»þ¤Ï¡¤MemoMT.fps/freezePS¤ò»È¤¦¤Ù¤·¡¥ -#ifdef DESTRUCTIVE - memoTrie = (allTrie,listrie) - listrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns (opt, (listrie, listrie), (fst qtl,[]), tcl cmn, rt cmn) avail t :: PriorSubsts BF [CoreExpr])) - allTrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns memoDeb avail t :: PriorSubsts BF [CoreExpr])) -#else - memoTrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns memoDeb avail t :: PriorSubsts BF [CoreExpr])) -#endif --- We need to specialize the type (to BF) in order to avoid ambiguity. - in memoDeb - where qtl = splitPrimss txs +mkTriePG :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> ProgGen +mkTriePG cmn classes tces = let qtl = splitPrimss tces + trie = mkTrieMD (mkCL cmn classes) qtl cmn + in PG trie +mkCL :: Common -> [Typed [CoreExpr]] -> ClassLib CoreExpr +mkCL cmn classes = CL $ mkTrieMD undefined ([],[map annotateTCEs classes]) cmn +mkTrieMD :: ClassLib CoreExpr -> ([[Prim]],[[Prim]]) -> Common -> MemoDeb (ClassLib CoreExpr) CoreExpr +mkTrieMD cl qtl cmn + = let trie = mkMT (tcl cmn) (\ty -> fromRc (let (avail,t) = splitArgs ty in freezePS (length avail) ty (mguFuns memoDeb avail t {- :: PriorSubsts BF [e] -}))) + memoDeb = (cl,trie,qtl,cmn) + in memoDeb -- moved from DebMT.lhs to avoid cyclic modules. -freezePS :: Search m => Type -> PriorSubsts m (Bag e) -> BFM (Possibility e) -freezePS ty ps +freezePS :: Search m => Int -> Type -> PriorSubsts m (Bag CoreExpr) -> m (Possibility CoreExpr) +freezePS arity ty ps = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) - in toMemo $ mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ fps mxty ps -fps :: Search m => Int -> PriorSubsts m es -> m (es,[(Int, Type)],Int) -fps mxty (PS f) = do (exprs, sub, m) <- f emptySubst (mxty+1) - return (exprs, filterSubst sub mxty, m) - where filterSubst :: Subst -> Int -> [(Int, Type)] + in mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ fps arity mxty ps +fps :: Search m => Int -> TyVar -> PriorSubsts m [CoreExpr] -> m ([CoreExpr],[(TyVar, Type)],TyVar) +fps arity mxty (PS f) = do + (exprs, sub, m) <- f emptySubst (mxty+1) + let es = filter (not . isAbsent arity) exprs + guard $ not $ length es `seq` null es + return (es, filterSubst sub mxty, m) + where filterSubst :: Subst -> TyVar -> [(TyVar, Type)] filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. -type Generator m e = MemoDeb e -> [Type] -> Type -> PriorSubsts m [e] +type Generator m e = MemoDeb (ClassLib e) e -> [Type] -> Type -> PriorSubsts m [e] mguProgramsIO, mguProgsIO :: Generator (RecompT IO) CoreExpr mguProgramsIO memodeb = applyDo (mguProgsIO memodeb) -mguProgsIO memodeb@(mt,_,cmn) = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> (\memodeb avail reqr -> memoPSRTIO (memoCond $ opt cmn) -- (\_ty _dep -> return (Disk "/tmp/memo/mlist") {- ¤È¤ê¤¢¤¨¤º¤³¤ì¤Ç¥Æ¥¹¥È -}) +mguProgsIO memodeb@(_,mt,_,cmn) = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> (\memodeb avail reqr -> memoPSRTIO (memoCond $ opt cmn) -- (\_ty _dep -> return (Disk "/tmp/memo/mlist") {- ¤È¤ê¤¢¤¨¤º¤³¤ì¤Ç¥Æ¥¹¥È -}) mt (\ty -> let (av,rr) = splitArgs ty in generateFuns mguProgramsIO memodeb av rr) (popArgs avail reqr)) memodeb newavail reqret) avail) -mguPrograms, mguProgs, mguFuns :: Search m => Generator m CoreExpr +mguPrograms, mguProgs :: (Search m) => Generator m CoreExpr +mguFuns :: (Search m) => Generator m CoreExpr mguPrograms memodeb = applyDo (mguProgs memodeb) -mguProgs memodeb = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail) + +mguProgs memodeb = wind (>>= (return . fmap (mapCE Lambda))) (lookupFunsShared mguFuns memodeb) +--mguProgs memodeb = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail) {- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ mguProgs memodeb avail (t0:->t1) = do result <- mguProgs memodeb (t0 : avail) t1 return (fmap Lambda result) @@ -156,22 +155,19 @@ generateFuns :: (Search m) => Generator m CoreExpr -- ^ recursive call -> Generator m CoreExpr -generateFuns rec memodeb@(_, (primgen,primmono),cmn) avail reqret - = let behalf = rec memodeb avail +generateFuns rec memodeb@(CL classLib, _mt, (primgen,primmono),cmn) avail reqret + = let clbehalf = mguPrograms classLib [] + behalf = rec memodeb avail lltbehalf = lookupListrie (opt cmn) rec memodeb avail -- heuristic filtration - lenavails = length avail - fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration + lenavails = genericLength avail +-- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration fe = filtExprs (guess $ opt cmn) rg = if tv0 $ opt cmn then retGenTV0 else if tv1 $ opt cmn then retGenTV1 else retGen - in fromAssumptions (PG memodeb) lenavails behalf mguPS reqret avail `mplus` mapSum (rg (PG memodeb) lenavails fe lltbehalf behalf reqret) primgen `mplus` mapSum (retPrimMono (PG memodeb) lenavails lltbehalf behalf mguPS reqret) primmono + in fromAssumptions cmn lenavails behalf mguPS reqret avail `mplus` mapSum (rg cmn lenavails fe clbehalf lltbehalf behalf reqret) primgen `mplus` mapSum (retPrimMono cmn lenavails clbehalf lltbehalf behalf mguPS reqret) primmono -#ifdef DESTRUCTIVE -lookupListrie rec (trie, (primgen,_),tcl,rtrie) avail t = rec ((snd trie, snd trie), (primgen,[]), tcl, rtrie) avail t -filtExprs = filterExprs -#else lookupListrie opt rec memodeb avail t - | constrL opt = mguAssumptions t avail +-- | constrL opt = mguAssumptions t avail | guess opt = do args <- rec memodeb avail t let args' = filter (not.isClosed.toCE) args when (null args') mzero @@ -180,8 +176,5 @@ let args' = filter (not.isConstrExpr.toCE) args when (null args') mzero return args' -filtExprs g a b | g = filterExprs a b - | otherwise = id -#endif \end{code} diff --git a/MagicHaskeller/ProgGenSF.lhs b/MagicHaskeller/ProgGenSF.lhs --- a/MagicHaskeller/ProgGenSF.lhs +++ b/MagicHaskeller/ProgGenSF.lhs @@ -3,47 +3,52 @@ -- \begin{code} -{-# LANGUAGE CPP, RelaxedPolyRec #-} -- Of course, LANGUAGE CPP must be before #ifdef. -#ifdef GHC7 -{-# LANGUAGE DatatypeContexts #-} -#else -{-# OPTIONS -fglasgow-exts #-} -#endif -module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF) where +{-# LANGUAGE CPP, RelaxedPolyRec, FlexibleInstances #-} +module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF(..), freezePS, funApSub_, funApSub_spec, lookupNormalized, tokoro10fst, mkTrieOptSFIO) where import MagicHaskeller.Types import MagicHaskeller.TyConLib import Control.Monad -import MagicHaskeller.CoreLang +import MagicHaskeller.CoreLang -- also imports unsafeShiftL/R for GHC<7.6 (which actually are shiftL/R respectively) import Control.Monad.Search.Combinatorial import MagicHaskeller.PriorSubsts import Data.List(partition, sortBy, sort, nub, (\\)) import Data.Ix(inRange) import MagicHaskeller.ClassifyDM -import MagicHaskeller.Classify(diffSortedBy) -import System.Random(mkStdGen, StdGen) import MagicHaskeller.Instantiate import MagicHaskeller.ProgramGenerator +import MagicHaskeller.ClassLib(mkCL, ClassLib(..), mguPrograms) import MagicHaskeller.Options(Opt(..)) import MagicHaskeller.Expression +import Data.Monoid -import MagicHaskeller.T10(mergesortWithBy) +import MagicHaskeller.T10(mergesortWithBy, diffSortedBy) import qualified Data.Map as M import MagicHaskeller.DebMT +import Data.Function(fix) +import System.IO(fixIO) +import System.IO.Unsafe(unsafeInterleaveIO) + +import Data.Bits -- used for absence analysis +import Data.Word + import Debug.Trace -- trace str = id -reorganize_ = reorganizer_ --- reorganize_ = id +reorganize_ f av = f $ mergesortWithBy const compare av +--reorganize_' = id +--reorganizer' = reorganize' +reorganizer' = id + reorganizerId' :: (Functor m, Expression e) => ([Type] -> m e) -> [Type] -> m e reorganizerId' = reorganizeId' --reorganizerId' = id @@ -57,7 +62,7 @@ -- Memoization table, created from primitive components --type ProgGenSF = PGSF AnnExpr type ProgGenSF = PGSF CoreExpr -- temporarily, until reorganize for ProgGenSF is implemented. -newtype Expression e => PGSF e = PGSF (MemoDeb e) -- internal data representation. +data PGSF e = PGSF (MemoDeb e) TypeTrie (ExpTrie e) -- internal data representation. -- ^ Program generator with synergetic filtration. -- This program generator employs filtration by random testing, and rarely generate semantically equivalent expressions more than once, while different expressions will eventually appear (for most of the types, represented with Prelude types, whose arguments are instance of Arbitrary and which return instance of Ord). -- The idea is to apply random numbers to the generated expressions, compute the quotient set of the resulting values at each depth of the search tree, and adopt the complete system of representatives for the depth and push the remaining expressions to one step deeper in the search tree. @@ -72,26 +77,27 @@ type ExpTip e = Matrix e type ExpTrie e = MapType (ExpTip e) -type TypeTrie e = MapType (Matrix (ExpTip e, Subst, Int)) - -type MemoTrie e = (TypeTrie e, ExpTrie e) +type TypeTrie = MapType (Matrix (Type, Subst, TyVar)) -lmt :: Expression e => MemoDeb e -> Type -> Matrix e -lmt memoDeb@((_,mt),_,cmn) fty = traceExpTy fty $ +lmt :: Expression e => ExpTrie e -> Type -> Matrix e +lmt mt fty = traceExpTy fty $ lookupMT mt fty -- ¤³¤Ã¤Á¤À¤Èlookup -- filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty -- ¤³¤Ã¤Á¤À¤Èrecompute -filtBF :: Expression e => Common -> Type -> DBound e -> Matrix e +filtBF :: Expression e => Common -> Type -> Recomp e -> Matrix e -- filtBF ty = fmap fromAnnExpr . filterBF tcl rtrie ty . fmap (toAnnExprWind (execute opt) ty) . tabulate --filtBF cmn ty = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . mapDepthDB uniqSorter -- . mondepth -filtBF cmn ty | classify = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . (\(DB g) -> DB (\d -> -- trace (shows (length (g d)) $ ('\t':) $ shows d $ ('\t':) $ show ty) $ - uniqSorter (g d))) - | otherwise = toMx . mapDepthDB uniqSorter +filtBF cmn ty | classify = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . fromRc . mapDepth uniqSort + | otherwise = toMx . mapDepth uniqSort fDM = filterDM -- ¤³¤Ã¤Á¤¬½¾Íè -- fDM = filterDMlite -- depth bound(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ë°ú¿ô¤ÎInt)¤ÎÂå¤ï¤ê¤Ë¡¤depth bound¤«¤é¤Îµ÷Î¥(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ëInt->[(a,¤³¤³¤ÎInt)])¤ò»È¤Ã¤Ænrnds¤Î²¿ÈÖÌܤ«¤ò·è¤á¤ë¤â¤Î¡¥ -- filterDM¤È°ã¤Ã¤Æ¡¤Æ±¤¸depth bound¤Ç¤â°ã¤¦Íð¿ô¤ò»È¤¦¤Î¤Ç¡¤filterListƱÍÍdepth¤ò¸Ù¤¤¤Àfiltration¤¬¤Ç¤­¤º¡¤·ë²Ì¤Ï¤¤¤Þ¤¤¤Á¡¥ -- ¤¿¤À¤·¡¤dynamic¤Ê´Ø¿ô¼«ÂΤò¥á¥â²½¤¹¤ì¤Ð¡¤³ÊÃʤ˥á¥â¤Ë¥Ò¥Ã¥È¤·¤ä¤¹¤¯¤Ê¤ë¤Ï¤º¡¥ +filtBFIO :: Expression e => Common -> Type -> Recomp e -> IO (Matrix e) +filtBFIO cmn ty rc | classify = dbtToCumulativeMx $ fmap fromAnnExpr $ filterDMIO cmn ty $ fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) $ fromRc $ mapDepth uniqSort rc + | otherwise = return $ toMx $ mapDepth uniqSort rc + lmtty mt fty = traceTy fty $ lookupMT mt fty @@ -103,16 +109,18 @@ -- memocond av ty = size ty + sum (map size av) < 10 -instance Expression e => ProgramGenerator (PGSF e) where - mkTrieOpt cmn tcesopt tces = PGSF (mkTrieOptSF cmn tcesopt tces) - matchingPrograms ty (PGSF x) = fromMx $ matchProgs x ty - unifyingPrograms ty px@(PGSF x) = catBags $ fromDB $ fmap (\ (es,_,_) -> map (toAnnExpr $ reducer px) es) $ unifyingPossibilities ty x - extractCommon (PGSF (_,_,cmn)) = cmn +instance ProgramGenerator (PGSF CoreExpr) where + mkTrieOpt = mkTrieOptSF + matchingProgramsWOAbsents ty (PGSF (_,_,cmn) _ etrie) = fromMx $ zipDepthMx (\i es -> if i < getArity ty - 1 then [] else es) $ matchProgs cmn etrie ty -- absents ga nai baai + matchingPrograms ty pgsf@(PGSF (_,_,cmn) _ _) = fromRc $ fmap (toAnnExprWindWind (reducer cmn) ty) $ lookupWithAbsents pgsf ty -- absents mo fukumeru baai + unifyingPrograms ty pgsf@(PGSF (_,_,cmn) _ _) = catBags $ fromRc $ fmap (\ ((es,_),_,_) -> map (toAnnExpr $ reducer cmn) es) $ unifyingPossibilities ty pgsf +instance Expression e => WithCommon (PGSF e) where + extractCommon (PGSF (_,_,cmn) _ _) = cmn unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0 -matchProgs :: Expression e => MemoDeb e -> Type -> Matrix AnnExpr -matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF memodeb) ty) $ lookupReorganized memodeb ty -- ¤³¤Ã¤Á¤À¤Èlookup +matchProgs :: Common -> ExpTrie CoreExpr -> Type -> Matrix AnnExpr +matchProgs cmn etrie ty = fmap (toAnnExprWindWind (reducer cmn) ty) $ lookupReorganized etrie ty -- ¤³¤Ã¤Á¤À¤Èlookup {- matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty) -- ¤³¤Ã¤Á¤À¤Èrecompute ¤È¤¤¤¦¤È¸ìÊÀ¤¬¤¢¤ë¡¥recompute¤·¤¿¤­¤ãlmt¤Î¤È¤³¤í¤òÊѤ¨¤ë¤Ù¤·¡¥ @@ -129,24 +137,20 @@ where ty = popArgs avail reqret -} -specializedPossibleTypes :: Expression e => Type -> MemoDeb e -> Recomp Type -specializedPossibleTypes ty memodeb = runPS (fmap (\(av,t) -> popArgs av t) $ specializedTypes memodeb [] ty) +specializedPossibleTypes :: Type -> MemoDeb CoreExpr -> TypeTrie -> Recomp Type +specializedPossibleTypes ty memodeb ttrie = runPS (fmap (\(av,t) -> popArgs av t) $ specializedTypes memodeb ttrie [] ty) -- specializedPossibleTypes ty memodeb@(_,((mt,_),_,_,_)) = fmap (\(_,s,_) -> apply s ty) $ toRc $ lmtty mt ty -type MemoDeb e = (MemoTrie e, (([[Prim]],[[Prim]]),([[Prim]],[[Prim]])), Common) +type MemoDeb e = (ClassLib e, (([[Prim]],[[Prim]]),([[Prim]],[[Prim]])), Common) -mkTrieOptSF :: Expression e => Common -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> MemoDeb e -mkTrieOptSF cmn txsopt txs - = let - memoDeb = (memoTrie, (qtlopt,qtl), cmn) - -- memoTrie :: MemoTrie - memoTrie = (typeTrie,expTrie) - typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb ty)) - expTrie = mkMTexp (tcl cmn) (\ty -> filtBF cmn ty $ matchFunctions memoDeb ty) - in memoDeb +mkTrieOptSF :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> PGSF CoreExpr +mkTrieOptSF cmn classes txsopt txs + = fix $ \pgsf -> PGSF memoDeb typeTrie $ mkMTexp (tcl cmn) (\ty -> filtBF cmn ty $ matchFunctions pgsf ty) where qtlopt = splitPrimss txsopt qtl = splitPrimss txs + memoDeb = (mkCL cmn classes, (qtlopt,qtl), cmn) + typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb typeTrie ty)) dbToCumulativeMx :: (Ord a) => DBound a -> Matrix a dbToCumulativeMx (DB f) = Mx $ case map (sort . map fst . f) [0..] of xss -> let result = zipWith (diffSortedBy compare) xss $ scanl (++) [] result in result -- ¿ʬËÜÅö¤ÏÌÀ¼¨Åª¤Ëlookup¤·Ä¾¤¹¤Ù¤­¡¥ @@ -156,6 +160,18 @@ in Mx $ zipWith (diffSortedBy compare) foo ([]:foo) -- in Mx $ zipWith (\\) foo ([]:foo) -} +mkTrieOptSFIO :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO (PGSF CoreExpr) +mkTrieOptSFIO cmn classes txsopt txs + = fixIO $ \pgsf -> fmap (PGSF memoDeb typeTrie) $ mkMTIO (tcl cmn) (\ty -> filtBFIO cmn ty $ matchFunctions pgsf ty) + where qtlopt = splitPrimss txsopt + qtl = splitPrimss txs + memoDeb = (mkCL cmn classes, (qtlopt,qtl), cmn) + typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb typeTrie ty)) +dbtToCumulativeMx :: (Ord a) => DBoundT IO a -> IO (Matrix a) +dbtToCumulativeMx (DBT f) = do ts <- interleaveActions $ map f [0..] + let xss = map (sort . map fst) ts + let result = zipWith (diffSortedBy compare) xss $ scanl (++) [] result + return $ Mx result -- ¿ʬËÜÅö¤ÏÌÀ¼¨Åª¤Ëlookup¤·Ä¾¤¹¤Ù¤­¡¥ mkMTty = mkMT mkMTexp = mkMT @@ -173,10 +189,13 @@ = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) in Mx $ map (tokoro10ap ty) $ scanl1 (++) $ unMx $ toMx $ unPS ps emptySubst (mxty+1) -} -freezePS :: Type -> PriorSubsts DBound (ExpTip e) -> Matrix (ExpTip e,Subst,Int) +freezePS :: Type -> PriorSubsts Recomp Type -> Matrix (Type,Subst,TyVar) freezePS ty ps = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) - in mapDepth (tokoro10ap ty) $ toMx $ fmap fst $ Rc $ unDB $ unPS ps emptySubst (mxty+1) +-- in zipDepthMx (\d tups -> map (\(Mx xss, s, i)->(xss!!d, s, i)) $ tokoro10ap ty tups) $ toMx $ fmap fst $ Rc $ unDB $ unPS ps emptySubst (mxty+1) + in mapDepth tokoro10ap $ toMx $ fmap fst $ Rc $ unDB $ fromRc $ unPS ps emptySubst (mxty+1) + -- tokoro10 in place of tokoro10ap ty causes an infinite loop. + -- fps mxty ps can be used in place of unPS ps emptySubst (mxty+1) -- MemoStingy.tokoro10 is different from T10.tokoro10, in that duplicates will be removed. -- (Note that the type can be specialized to [(Type,k,i)] -> [(Type,k,i)]) @@ -185,126 +204,208 @@ -- tokoro10fstfst = mergesortWithBy const (\ ((k,_),_,_) ((l,_),_,_) -> k `compare` l) -tokoro10ap :: Type -> [(a,Subst,i)] -> [(a,Subst,i)] --- tokoro10ap ty = mergesortWithBy const (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty)) -tokoro10ap ty = M.elems . M.fromListWith const . map (\ t@(_,k,_) -> ( {- normalize -} (apply k ty), t)) +tokoro10ap :: [(Type,s,i)] -> [(Type,s,i)] +-- tokoro10ap = mergesortWithBy const (\ (t,_,_) (u,_,_) -> compare t u) +tokoro10ap = M.elems . M.fromListWith const . map (\ t@(ty,_,_) -> ( {- normalize -} ty, t)) -- avail¤Ë¤·¤íType¤Ë¤·¤íapply¤µ¤ì¤Æ¤¤¤ë¡¥ -- ¤À¤«¤é¤³¤½¡¤runAnotherPSŪ¤ËemptySubst¤ËÂФ·¤Æ¼Â¹Ô¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡© ¤Ç¤â¡¤Substitution¤Ã¤Æ¤½¤ó¤Ê¤Ë¤Ç¤«¤¯¤Ê¤é¤Ê¤«¤Ã¤¿¤Î¤Ç¤Ï¡©FiniteMap¤Ç¤âassoc list¤Ç¤âÊѤï¤é¤Ê¤«¤Ã¤¿µ¤¤¬¡¥ -specializedTypes :: (Search m, Expression e) => MemoDeb e -> [Type] -> Type -> PriorSubsts m ([Type],Type) -specializedTypes memodeb avail t = do specializedCases memodeb avail t - subst <- getSubst - return (map (apply subst) avail, apply subst t) + +fps :: Search m => TyVar -> PriorSubsts m e -> m (e,[(TyVar, Type)],TyVar) +fps mxty (PS f) = do (exprs, sub, m) <- f emptySubst (mxty+1) + return (exprs, filterSubst sub mxty, m) + where filterSubst :: Subst -> TyVar -> [(TyVar, Type)] + filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. + + + + +specializedTypes :: (Search m) => MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type],Type) +specializedTypes memodeb ttrie avail t = do _ <- specializedCases memodeb ttrie avail t + subst <- getSubst + return (map (apply subst) avail, apply subst t) -- specializedCases is the same as unifyableExprs, except that the latter returns PriorSubsts BF [CoreExpr], and that the latter considers memodepth. -specializedCases, specCases, specCases' :: (Search m, Expression e) => MemoDeb e -> [Type] -> Type -> PriorSubsts m () -specializedCases memodeb = applyDo (specCases memodeb) -specCases memodeb = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail) -{- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ -specCases memodeb avail (t0:->t1) = specCases memodeb (t0 : avail) t1 -specCases memodeb avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail --} +specializedCases, specCases :: (Search m) => MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet +specializedCases memodeb ttrie = applyDo (specCases memodeb ttrie) +-- specCases memodeb = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail) +specCases memodeb ttrie avail (t0:->t1) = fmap (`unsafeShiftR` 1) $ specCases memodeb ttrie (t0 : avail) t1 +specCases memodeb ttrie avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb ttrie newavail reqret) avail -uniExprs_ :: (Search m, Expression e) => MemoDeb e -> [Type] -> Type -> PriorSubsts m () +uniExprs_ :: (Search m) => MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet +{- uniExprs_ memodeb avail t = convertPS fromRc $ psListToPSRecomp lfp where lfp depth - | memocond depth = lookupUniExprs memodeb avail t depth >> return () + | memocond depth = lookupUniExprs memodeb avail t depth | otherwise = makeUniExprs memodeb avail t depth >> return () +-} +uniExprs_ memodeb ttrie avail t + = convertPS fromMx $ lookupNormalizedSharedBits (\ixs _ -> ixs) (lookupTypeTrie memodeb ttrie) avail t -lookupUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] (ExpTip e) -lookupUniExprs memodeb@((mt,_),_,_) avail t depth - = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t +{- +lookupUniExprs :: MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] () +lookupUniExprs memodeb@(_,(mt,_),_,_) avail t depth + = fmap (const ()) $ lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t -makeUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] Type +makeUniExprs :: MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] Type makeUniExprs memodeb avail t depth = convertPS tokoro10fst $ - do psRecompToPSList (reorganize_ (\av -> specCases' memodeb av t) avail) depth + do psRecompToPSList (reorganize_' (\av -> specCases' memodeb av t) avail) depth sub <- getSubst return $ quantify (apply sub $ popArgs avail t) +-} lookupReorganized md typ = let (avs, retty) = splitArgs $ normalize typ in reorganizerId' (\av -> lmt md $ popArgs av retty) avs -- entry point for memoization -specTypes :: (Search m, Expression e) => MemoDeb e -> Type -> PriorSubsts m (ExpTip e) -specTypes memodeb@((_,mt),_,_) ty - = do let (avail,t) = splitArgs ty - reorganize_ (\av -> specCases' memodeb av t) avail --- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× - typ <- applyPS ty - return $ lookupReorganized memodeb typ -specTypesRecompute :: (Expression e) => MemoDeb e -> Type -> PriorSubsts DBound (ExpTip e) -specTypesRecompute memodeb@((_,mt),_,cmn) ty - = do let (avail,t) = splitArgs ty - reorganize_ (\av -> specCases' memodeb av t) avail +specTypes :: MemoDeb CoreExpr -> TypeTrie -> Type -> PriorSubsts Recomp Type +specTypes memodeb ttrie ty + = let (avail,t) = splitArgs ty + in convertPS (zipDepthRc (\i es -> if i < length avail - 1 then [] else es)) $ do + reorganize_ (\av -> specCases' memodeb ttrie av t) avail -- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× - typ <- applyPS ty - return (filtBF cmn typ $ matchFunctions memodeb typ) -- ¤³¤Î¹Ô¤Î¤ß°ã¤¦¡¥ + applyPS ty +instance Monoid BitSet where + mappend = (.|.) + mempty = 0 -funApSub_ :: Search m => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m () -funApSub_ lltbehalf behalf (t:>ts) = do lltbehalf t - funApSub_ lltbehalf behalf ts -funApSub_ lltbehalf behalf (t:->ts) = do behalf t - funApSub_ lltbehalf behalf ts -funApSub_ lltbehalf behalf _t = return () +funApSub_ :: (Search m, Monoid a) => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m a) -> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a +funApSub_ clbehalf lltbehalf behalf (t:=>ts) = do clbehalf t + funApSub_ clbehalf lltbehalf behalf ts +funApSub_ clbehalf lltbehalf behalf (t:>ts) = liftM2 mappend (lltbehalf t) (funApSub_ clbehalf lltbehalf behalf ts) +funApSub_ clbehalf lltbehalf behalf (t:->ts) = liftM2 mappend (behalf t) (funApSub_ clbehalf lltbehalf behalf ts) +funApSub_ clbehalf lltbehalf behalf _t = return mempty -funApSub_spec behalf = funApSub_ behalf behalf +funApSub_spec clbehalf behalf = funApSub_ clbehalf behalf behalf +funApSub_forcingNil :: (Type -> PriorSubsts Recomp ()) -> (Type -> PriorSubsts Recomp BitSet) -> (Type -> PriorSubsts Recomp BitSet) -> Type -> BitSet -> PriorSubsts Recomp () +funApSub_forcingNil clbehalf lltbehalf behalf t bsf + = funApSub_forcingNil_cont clbehalf lltbehalf behalf t bsf $ \bs -> guard $ bs == 0 +funApSub_forcingNil_spec clbehalf behalf = funApSub_forcingNil clbehalf behalf behalf + +funApSub_forcingNil_cont :: (Type -> PriorSubsts Recomp ()) -> (Type -> PriorSubsts Recomp BitSet) -> (Type -> PriorSubsts Recomp BitSet) -> Type -> BitSet -> (BitSet->PriorSubsts Recomp a) -> PriorSubsts Recomp a +funApSub_forcingNil_cont clbehalf lltbehalf behalf (t:=>ts) bsf cont = do clbehalf t + funApSub_forcingNil_cont clbehalf lltbehalf behalf ts bsf cont +funApSub_forcingNil_cont clbehalf lltbehalf behalf (t:>ts) bsf cont = do bse <- lltbehalf t + let newRemaining = bsf .&. complement bse + forceNil newRemaining $ + funApSub_forcingNil_cont clbehalf lltbehalf behalf ts newRemaining cont +funApSub_forcingNil_cont clbehalf lltbehalf behalf (t:->ts) bsf cont = do bse <- behalf t + let newRemaining = bsf .&. complement bse + forceNil newRemaining $ + funApSub_forcingNil_cont clbehalf lltbehalf behalf ts newRemaining cont +funApSub_forcingNil_cont clbehalf lltbehalf behalf _t bsf cont = cont bsf + +funApSub_forcingNil_cont_spec clbehalf behalf = funApSub_forcingNil_cont clbehalf behalf behalf + +mguAssumptionsBits :: (MonadPlus m) => Type -> [Type] -> PriorSubsts m BitSet +mguAssumptionsBits patty assumptions = applyDo mguAssumptionsBits' assumptions patty +mguAssumptionsBits' assumptions patty = msum $ zipWith (\n t -> mguPS patty t >> return (1 `shiftL` n)) [0..] assumptions + +specCases' :: MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp () -- specCases' trie prims@(primgen,primmono) avail reqret = msum (map (retMono.fromPrim) primmono) `mplus` msum (map retMono fromAvail ++ map retGen primgen) -specCases' memodeb@((ttrie,etrie), (prims@(primgen,primmono),_),cmn) avail reqret - = mapSum retPrimMono primmono `mplus` msum (map retMono avail) `mplus` mapSum retGen primgen - where fas | constrL $ opt cmn = funApSub_ lltbehalf behalf - | otherwise = funApSub_spec behalf - where behalf = specializedCases memodeb avail - lltbehalf = flip mguAssumptions_ avail +specCases' memodeb@(CL classLib, (prims@(primgen,primmono),_),cmn) ttrie avail reqret + = mapSum retPrimMono primmono `mplus` msum (zipWith retMono (iterate (`unsafeShiftL` 1) 1) avail) `mplus` mapSum retGen primgen + where fas | constrL $ opt cmn = funApSub_ clbehalf lltbehalf behalf + | otherwise = funApSub_spec clbehalf behalf + fasf| constrL $ opt cmn = funApSub_forcingNil clbehalf lltbehalf behalf + | otherwise = funApSub_forcingNil_spec clbehalf behalf + behalf = specializedCases memodeb ttrie avail + lltbehalf ty = mguAssumptionsBits ty avail + clbehalf ty = mguPrograms classLib ty >> return () + lenavails = length avail + fullBits | lenavails > 29 = 0 + | otherwise = (1 `unsafeShiftL` lenavails) - 1 -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () retPrimMono (arity, retty, numtvs, _xs:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs mguPS reqret (mapTV (tvid+) retty) - fas (mapTV (tvid+) ty) - -- retMono :: Type -> PriorSubsts BFT () - retMono ty = napply (getArity ty) delayPS $ - do mguPS reqret (getRet ty) - fas ty + fasf (mapTV (tvid+) ty) fullBits + -- retMono :: BitSet -> Type -> PriorSubsts BFT () + retMono ix ty = napply (getArity ty) delayPS $ do + mguPS reqret (getRet ty) + fasf ty $ fullBits .&. complement ix -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤­¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡© -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« mkSubsts (tvndelay $ opt cmn) tvid reqret - fas (mapTV (tvid+) ty) + funApSub_forcingNil_cont_spec clbehalf behalf (mapTV (tvid+) ty) fullBits $ \i -> do + gentvar <- applyPS (TV tvid) - gentvar <- applyPS (TV tvid) + guard (orderedAndUsedArgs gentvar) + fasf gentvar i - guard (orderedAndUsedArgs gentvar) - fas gentvar +-- absent¤ò´Þ¤á¤ë¾ì¹ç¤³¤Ã¤Á¤ò»È¤¦ +lookupWithAbsents :: Search m => PGSF CoreExpr -> Type -> m CoreExpr +lookupWithAbsents memodeb ty + = case splitArgs ty of + (a,r) -> wind (fmap (mapCE Lambda)) (lookupNormalizedSharedET (lookupTypeTrieAndExpTrie memodeb)) a r +--unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalizedShared (\ixs -> map (decodeVarsCE ixs)) (lookupTypeTrieAndExpTrie memodeb))) -type Generator m e = MemoDeb e -> [Type] -> Type -> PriorSubsts m [e] +lookupNormalizedSharedET :: (Search m, Search n) => (Type -> m ([CoreExpr], Subst, TyVar)) -> [Type] -> Type -> n CoreExpr +lookupNormalizedSharedET fun avail t + = let annAvails = zip [0..] avail + in fromRc $ Rc $ \d -> [ decodeVarsCE ixs e + | avs <- combs (d+1) annAvails + , let (ixs, newavails) = unzip avs + (tn, _decoder) = encode newt (maxVarID newt + 1) + newt = popArgs newavails t + , (exprs, _, _) <- unRc (toRc (fun tn)) d + , e <- exprs + ] -unifyableExprs :: Expression e => Generator DBound e -unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrie memodeb))) +type Generator m e = PGSF e -> [Type] -> Type -> PriorSubsts m ([e], BitSet) --- memocondexp d = True -memocondexp d = 0 (map (mapCE Lambda) es, bs `unsafeShiftR` 1))) + (lookupNormalizedShared (\ixs ixBits e -> (map (decodeVarsCE ixs) e, ixBits)) (lookupTypeTrieAndExpTrie memodeb))) +--unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalizedShared (\ixs -> map (decodeVarsCE ixs)) (lookupTypeTrieAndExpTrie memodeb))) -lookupTypeTrie :: Expression e => MemoDeb e -> Type -> DBound ([e], Subst, Int) -lookupTypeTrie memodeb@((mt,_), _, _) t - = DB $ \db -> let Mx tss | memocondexp db = lmtty mt t - | otherwise = freezePS t $ specTypesRecompute memodeb t - in let ts = tss !! db in concat [ zipWith (\depth ys -> ((ys, s, i), db-depth)) [0..db] yss | (Mx yss, s, i) <- ts ] --- in DB $ \db -> let ts = tss !! db in [ ((yss!!depth, s, i), db-depth) | depth <- [0..db], (Mx yss, s, i) <- ts ] -- same as the above (but maybe a little less efficient). --- in DB $ \db -> concat $ zipWith (\depth ts -> map (\(Mx yss, s, i) -> ((yss!!depth, s, i), db-depth)) ts) [0..db] tss -- cumulative in type. This would be necessary if TypeTrie were not cumulative, but actually TypeTrie is. +-- memocondexp t d = 1 (Type -> m (e, Subst, Int)) -> [Type] -> Type -> PriorSubsts m e +lookupTypeTrie :: MemoDeb CoreExpr -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar) +lookupTypeTrie memodeb@(_, _, cmn) ttrie t + = Rc $ \d -> unMx (if memoCondPure (opt cmn) t d + then lookupNorm (lmtty ttrie) t + else freezePS t $ specTypes memodeb ttrie t ) !! d -- if d<8 then d else 7 +lookupTypeTrieAndExpTrie :: PGSF CoreExpr -> Type -> Recomp ([CoreExpr], Subst, TyVar) +lookupTypeTrieAndExpTrie (PGSF memodeb@(_, _, cmn) ttrie etrie) t + = Rc $ \d -> if memoCondPure (opt cmn) t d + then [ (unMx (lookupReorganized etrie $ apply s t) !! d, s, i) + | (_ty, s, i) <- unMx (lookupNormReorganized (lmtty ttrie) t) !! d {- if d<8 then d else 7 -} ] + else -- [ (unMx (filtBF cmn ty $ matchFunctions memodeb ty) !! d, s, i) -- exptrie¤âƱÍͤËmemoCondPure¤ò»È¤¦¾ì¹ç¡¥ + [ (unMx (lookupReorganized etrie $ apply s t) !! d, s, i) -- exptrie¤Ç¤ÏÁ´Éômemoize¤¹¤ë¾ì¹ç¡¥ + | (ty, s, i) <- unMx (freezePS t $ specTypes memodeb ttrie t) !! d {- if d<8 then d else 7 -} ] + +lookupNormReorganized fun typ = let (avs, retty) = splitArgs typ + in reorganize_ (\av -> lookupNorm fun (popArgs av retty)) avs +lookupNorm :: MonadPlus m => (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar) +lookupNorm = id +{- +lookupNorm fun typ + = do let + mx = maxVarID typ + 1 + (tn, decoder) = encode typ mx + (es, sub, m) <- fun tn + return (es, retrieve decoder sub, mx+m) +-} + + +lookupNormalized :: MonadPlus m => (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e lookupNormalized fun avail t = do mx <- getMx let typ = popArgs avail t @@ -313,49 +414,227 @@ updatePS (retrieve decoder sub) updateMx (m+) return es +lookupNormalizedShared :: (Search m, Search n) => ([Int8] -> BitSet -> e -> r) -> (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts n r +lookupNormalizedShared ceDecoder fun avail t + = let annAvails = zip3 [0..] (iterate (`unsafeShiftL` 1) 1) avail + in PS (\subst mx -> fromRc $ Rc $ \d ->concat + [ map (\ (exprs, sub, m) -> (ceDecoder ixs ixBits exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ unRc (toRc (fun tn)) d + | annAvs <- combs (d+1) annAvails + , let (ixs, ixBitss, newavails) = unzip3 annAvs + ixBits = foldl (.|.) 0 ixBitss + (tn, decoder) = encode (popArgs newavails t) mx + ]) +type BitSet = Word32 +#if __GLASGOW_HASKELL__ < 706 +countBits = countBits32 +#else +countBits = popCount +#endif +-- Also, if BitSet = Integer, countBits32 should be used in place of popCount because popCount for Integers is inefficient. + +lookupNormalizedSharedBits :: (Search m, Search n) => (BitSet -> e -> r) -> (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts n r +lookupNormalizedSharedBits f = lookupNormalizedShared (const f) + + tokoro10fst :: (Eq k, Ord k) => [(k,s,i)] -> [(k,s,i)] -- tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l) tokoro10fst = M.elems . M.fromListWith const . map (\ t@(k,_,_) -> (k,t)) -- entry for memoization -matchFunctions :: Expression e => MemoDeb e -> Type -> DBound e -matchFunctions memodeb ty = case splitArgs (saferQuantify ty) of (avail,t) -> matchFuns memodeb avail t +matchFunctions :: PGSF CoreExpr -> Type -> Recomp CoreExpr +matchFunctions memodeb ty = -- mapDepth (filter (not . isAbsent (getArity ty))) $ -- KOKO 1 + case splitArgs (saferQuantify ty) of (avail,t) -> matchFuns memodeb avail t -- saferQuantify ty = let offset = maxVarID (unquantify ty) + 1 in quantify' $ mapTV (offset+) ty -matchFuns :: Expression e => MemoDeb e -> [Type] -> Type -> DBound e -matchFuns memodeb avail reqret = catBags $ runPS (matchFuns' unifyableExprs memodeb avail reqret) +matchFuns :: PGSF CoreExpr -> [Type] -> Type -> Recomp CoreExpr +matchFuns memodeb avail reqret = zipDepthRc (\i es -> if i < length avail - 1 then [] else es) $ catBags $ runPS (matchFuns' unifyableExprs memodeb avail reqret) -matchFuns' :: (Search m, Expression e) => Generator m e -> Generator m e +matchFuns' :: Generator Recomp CoreExpr -> PGSF CoreExpr -> [Type] -> Type -> PriorSubsts Recomp [CoreExpr] -- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDeb¤Î·¿¤Î°ã¤¤¤Ç¤³¤ì¤Ï¤¦¤Þ¤¯¤¤¤«¤Ê¤ó¤À¡¥ -matchFuns' rec md@(_, (_,(primgen,primmono)),cmn) avail reqret - = let behalf = rec md avail +matchFuns' rec md@(PGSF (CL classLib, (_,(primgen,primmono)),cmn) _ _) avail reqret + = let clbehalf = mguPrograms classLib + behalf = rec md avail lltbehalf = lookupListrie lenavails rec md avail -- heuristic filtration lenavails = length avail + fullBits | lenavails > 29 = 0 + | otherwise = (1 `unsafeShiftL` lenavails) - 1 -- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration fe = filtExprs (guess $ opt cmn) - in fromAssumptions (PGSF md) lenavails behalf (\a b -> guard $ a==b) reqret avail `mplus` - mapSum (retPrimMono (PGSF md) lenavails lltbehalf behalf matchPS reqret) primmono `mplus` - mapSum (( if tv0 $ opt cmn then retGenTV0 else - if tv1 $ opt cmn then retGenTV1 else retGenOrd) (PGSF md) lenavails fe lltbehalf behalf reqret) primgen + in fromAssumptionsBits cmn lenavails fullBits behalf (\a b -> guard $ a==b) reqret avail `mplus` + convertPS (zipDepthRc (\i es -> if i < lenavails then [] else es)) + (mapSum (retPrimMonoBits cmn lenavails fullBits clbehalf lltbehalf behalf matchPS reqret) primmono `mplus` + mapSum (( if tv0 $ opt cmn then retGenTV0Bits else + if tv1 $ opt cmn then retGenTV1Bits else retGenOrdBits) cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret) primgen) +-- mapSum (retGenTV1Bits cmn lenavails fe clbehalf lltbehalf behalf reqret) primgen +fromAssumptionsBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> Type -> PriorSubsts Recomp ()) -> Type -> [Type] -> PriorSubsts Recomp [e] +fromAssumptionsBits cmn lenavails fullBits behalf mps reqret avail = msum $ map (retMonoBits cmn lenavails fullBits behalf (flip mps reqret)) (zip [0..] avail) + +retMonoBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ()) -> (Int, Type) -> PriorSubsts Recomp [e] +retMonoBits cmn lenavails fullBits behalf tok fromBlah + = do let (n, ty) = fromBlah + (arity,args,retty) = revSplitArgs ty + tok retty +{- + (es,ixBits) <- convertPS (ndelay arity) $ + fapBits behalf args ([ mkHead (reducer cmn) lenavails arity $ X n], 1 `shiftL` n) + guard $ ixBits == fullBits -- KOKO 2 + return es +-} + convertPS (ndelay arity) $ + funApSubBits_forcingNil undefined behalf behalf ty ([ mkHead (reducer cmn) lenavails arity $ X $ fromIntegral n], fullBits `clearBit` n) + + + +retPrimMonoBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> Type -> PriorSubsts Recomp ()) -> Type -> Prim -> PriorSubsts Recomp [e] +retPrimMonoBits cmn lenavails fullBits clbehalf lltbehalf behalf mps reqret (arity, retty, numtvs, xs:::ty) + = do tvid <- reserveTVars numtvs + mps (mapTV (tvid+) retty) reqret + convertPS (ndelay arity) $ + funApSubBits_forcingNil clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs, fullBits) + +funApSubBits, funApSubBits_resetting :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ([e],BitSet)) -> (Type -> PriorSubsts m ([e],BitSet)) -> Type -> ([e],BitSet) -> PriorSubsts m ([e],BitSet) +funApSubBits = funApSubOpBits (<$>) +funApSubOpBits op clbehalf lltbehalf behalf = faso + where faso (t:=>ts) (funs, bsf) + = do args <- clbehalf t + faso ts (liftM2 op funs args, bsf) + faso (t:> ts) (funs, bsf) + = do (args, bse) <- lltbehalf t + faso ts (liftM2 op funs args, bsf .|. bse) + -- original. + faso (t:->ts) (funs, bsf) + = do (args, bse) <- behalf t + faso ts (liftM2 op funs args, bsf .|. bse) + faso _ tup = return tup +funApSubBits_resetting = funApSubOpBits_resetting (<$>) +funApSubOpBits_resetting op clbehalf lltbehalf behalf = faso + where faso (t:=>ts) (funs, bsf) + = do args <- clbehalf t + faso ts (liftM2 op funs args, bsf) + faso (t:> ts) (funs, bsf) + = do (args, bse) <- lltbehalf t + faso ts (liftM2 op funs args, bsf .&. complement bse) + -- original. + faso (t:->ts) (funs, bsf) + = do (args, bse) <- behalf t + faso ts (liftM2 op funs args, bsf .&. complement bse) + faso _ tup = return tup +fapBits behalf ts tups = foldM (\ (fs,bsf) t -> do (args, bse) <- behalf t + return (liftM2 (<$>) fs args, bsf .|. bse)) + tups + ts + +forceNil :: BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e +forceNil newRemaining = convertPS (zipDepthRc (\i es -> if i < countBits newRemaining - 1 then [] else es)) + +funApSubBits_forcingNil :: (Expression e) => (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> Type -> ([e],BitSet) -> PriorSubsts Recomp [e] +funApSubBits_forcingNil clbehalf lltbehalf behalf ty = funApSubOpBits_forcingNil (aeAppErr (" to the request of "++show ty)) clbehalf lltbehalf behalf ty +funApSubBits_forcingNil_cont :: (Expression e) => (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> Type -> ([e],BitSet) -> (([e],BitSet) -> PriorSubsts Recomp [e]) -> PriorSubsts Recomp [e] +funApSubBits_forcingNil_cont clbehalf lltbehalf behalf ty = funApSubOpBits_forcingNil_cont (aeAppErr (" to the request of "++show ty)) clbehalf lltbehalf behalf ty +funApSubOpBits_forcingNil_cont op clbehalf lltbehalf behalf = faso + where faso (t:=>ts) (funs, bsf) cont + = do args <- clbehalf t + faso ts (liftM2 op funs args, bsf) cont + faso (t:> ts) (funs, bsf) cont + = do (args, bse) <- lltbehalf t + let newRemaining = bsf .&. complement bse + forceNil newRemaining $ + faso ts (liftM2 op funs args, newRemaining) cont + -- original. + faso (t:->ts) (funs, bsf) cont + = do (args, bse) <- behalf t + let newRemaining = bsf .&. complement bse + forceNil newRemaining $ + faso ts (liftM2 op funs args, newRemaining) cont + faso _ (funs, bsf) cont = cont (funs, bsf) +funApSubOpBits_forcingNil op clbehalf lltbehalf behalf t tup + = funApSubOpBits_forcingNil_cont op clbehalf lltbehalf behalf t tup $ \(funs, bsf) -> + do guard $ bsf == 0 + return funs +-- Data.Bits.popCount does the job. However, instance Bits Integer uses popCountDefault, which uses the naive algorithm. +countBits32 bin + = let quad = bin - ((bin `unsafeShiftR` 1) .&. 0x55555555) -- quadary coded + hex = (quad .&. 0x33333333) + ((quad `unsafeShiftR` 2) .&. 0x33333333) -- hexadecimalary coded + in fromIntegral $ ((((hex + (hex `unsafeShiftR` 4)) .&. 0x0F0F0F0F) * 0x01010101) `unsafeShiftR` 24) .&. 0xFF -- The last (.&. 0xFF) should not be necessary when using Word32. + +retGenOrdBits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) + = convertPS (ndelay arity) $ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë + -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤­¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡© + -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« + a <- mkSubsts (tvndelay $ opt cmn) tvid reqret + (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits) + gentvar <- applyPS (TV tvid) + guard (orderedAndUsedArgs gentvar) -- ¤³¤ÎÊÕ¤Îcheck¤òTVn¤ËÆþ¤ëÁ°¤ÎÁᤤÃʳ¬¤Ë¤ä¤ë¤Î¤Ï1¤Ä¤Î¹Í¤¨Êý¤À¤¬¡¤TVnÃæ¤Ëreplace¤µ¤ì¤¿¤ê¤Ï¤·¤Ê¤¤¤Î¤«? + (es, bs2) <- funApSub'' False gentvar (fe gentvar ty exprs, bs1) + guard $ bs2 == 0 + return es + where +-- funApSub'' filtexp (TV _ :-> _) funs = mzero -- mkSubsts¤ÇƳÆþ¤µ¤ì¤¿tyvars¤¬»È¤ï¤ì¤Æ¤¤¤Ê¤¤¥±¡¼¥¹¡¥replace¤µ¤ì¤¿·ë²ÌTV¤Ã¤Æ¥±¡¼¥¹¤Ï¤È¤ê¤¢¤¨¤ºÌµ»ë.... + funApSub'' filtexp (t:->ts@(u:->_)) (funs, bs) +-- | t > u = mzero + | otherwise = do (args, ixs) <- behalf t + funApSub'' (t==u) ts (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e ] + else liftM2 (<$>) funs args, + bs .&. complement ixs) +-- ¤Æ¤æ¡¼¤«t¤Èu¤¬Æ±¤¸¤Ê¤é¤Ð¤â¤Ã¤È¤¤¤í¤ó¤Ê¤³¤È¤¬¤Ç¤­¤½¤¦¡¥ + funApSub'' filtexp (t:->ts) (funs, bs) + = do (args, ixs) <- behalf t + return (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e] + else liftM2 (<$>) funs args, + bs .&. complement ixs) + funApSub'' _fe _t tups = return tups + +retGenTV1Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) + = convertPS (ndelay arity) $ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë + -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤­¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡© + -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« + a <- mkSubst (tvndelay $ opt cmn) tvid reqret +{- + (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits) + gentvar <- applyPS (TV tvid) + guard (usedArg (tvid+1) gentvar) + funApSubBits_forcingNil clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs, bs1) +-} + funApSubBits_forcingNil_cont clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits) $ \(exprs, bs1) -> do + gentvar <- applyPS (TV tvid) + guard (usedArg (tvid+1) gentvar) + funApSubBits_forcingNil clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs, bs1) + +retGenTV0Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) + = convertPS (ndelay arity) $ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë + -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤­¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡© + -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« + updatePS (unitSubst tvid reqret) + exprs <- funApSubBits_forcingNil clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs, fullBits) + gentvar <- applyPS (TV tvid) + return $ fe gentvar ty exprs + + + + +matchAssumptionsBits :: (MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m ([e],BitSet) +matchAssumptionsBits cmn lenavails reqty assumptions + = do s <- getSubst + let newty = apply s reqty + msum $ zipWith (\n t -> matchPS newty t >> return ([mkHead (reducer cmn) lenavails (getLongerArity newty) (X n)], 1 `shiftL` fromIntegral n)) [0..] assumptions +-- match ¤Î¾ì¹ç¡¤Ä̾ï¤Ïreqty¤ÎÊý¤À¤±apply subst¤¹¤ì¤Ð¤è¤¤¡¥ + lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e -lookupListrie lenavails rec memodeb@(_,_,cmn) avail t - | constrL opts = matchAssumptions (PGSF memodeb) lenavails t avail +lookupListrie lenavails rec memodeb avail t + | constrL opts = matchAssumptionsBits cmn lenavails t avail | guess opts = do - args <- rec memodeb avail t + (args, ixBits) <- rec memodeb avail t let args' = filter (not.isClosed.toCE) args when (null args') mzero - return args' + return (args', ixBits) | otherwise = do - args <- rec memodeb avail t + (args, ixBits) <- rec memodeb avail t let args' = filter (not.isConstrExpr.toCE) args when (null args') mzero - return args' + return (args', ixBits) where opts = opt cmn -filtExprs :: Expression e => Bool -> Type -> Type -> [e] -> [e] -filtExprs g a b | g = filterExprs a b - | otherwise = id - + cmn = extractCommon memodeb \end{code} diff --git a/MagicHaskeller/ProgGenSFIORef.lhs b/MagicHaskeller/ProgGenSFIORef.lhs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/ProgGenSFIORef.lhs @@ -0,0 +1,343 @@ +-- +-- (c) Susumu Katayama +-- + +\begin{code} +{-# LANGUAGE CPP, RelaxedPolyRec, FlexibleInstances #-} +module MagicHaskeller.ProgGenSFIORef(ProgGenSFIORef, PGSFIOR) where +import MagicHaskeller.Types +import MagicHaskeller.TyConLib +import Control.Monad +import MagicHaskeller.CoreLang +import Control.Monad.Search.Combinatorial +import MagicHaskeller.PriorSubsts +import Data.List(partition, sortBy, sort, nub, (\\)) +import Data.Ix(inRange) + +import MagicHaskeller.ClassifyDM + +import MagicHaskeller.Instantiate + +import MagicHaskeller.ProgramGenerator +import MagicHaskeller.ProgGen(mkCL, ClassLib(..), mguPrograms) +import MagicHaskeller.ProgGenSF(funApSub_, funApSub_spec, lookupNormalized, tokoro10fst) +import MagicHaskeller.Options(Opt(..)) + +import MagicHaskeller.Expression + +import MagicHaskeller.MemoToFiles hiding (freezePS, fps, memoRTIO) + +import MagicHaskeller.T10(mergesortWithBy, diffSortedBy) + +import qualified Data.Map as M + +import MagicHaskeller.DebMT + +import MagicHaskeller.FMType +import Data.IORef +import Data.Array +import Data.Ix + +import MagicHaskeller.ShortString(readBriefly, showBriefly) +import System.Directory(doesFileExist, createDirectoryIfMissing) + +import Debug.Trace +-- trace str = id + +reorganize_ = reorganizer_ +-- reorganize_ = id + +reorganizerId' :: (Functor m, Expression e) => ([Type] -> m e) -> [Type] -> m e +reorganizerId' = reorganizeId' +--reorganizerId' = id + +classify = True +traceExpTy _ = id +-- traceExpTy fty = trace ("lookupexp "++ show fty) +traceTy _ = id +-- traceTy fty = trace ("lookup "++ show fty) + +-- Memoization table, created from primitive components +type ProgGenSFIORef = PGSFIOR CoreExpr +data PGSFIOR e = PGSFIOR (ExpTrie e) (MemoDeb e) -- internal data representation. +-- ^ Program generator with synergetic filtration. +-- This program generator employs filtration by random testing, and rarely generate semantically equivalent expressions more than once, while different expressions will eventually appear (for most of the types, represented with Prelude types, whose arguments are instance of Arbitrary and which return instance of Ord). +-- The idea is to apply random numbers to the generated expressions, compute the quotient set of the resulting values at each depth of the search tree, and adopt the complete system of representatives for the depth and push the remaining expressions to one step deeper in the search tree. +-- (Thus, adoption of expressions that may be equivalent to another already-generated-expression will be postponed until their \"uniqueness\" is proved.) +-- As a result, (unlike "ProgGen",) expressions with size N may not appear at depth N but some deeper place. +-- +-- "ProgGenSF" is more efficient along with a middle-sized primitive set (like @reallyall@ found in LibTH.hs), +-- but is slower than "ProgGen" for a small-sized one. +-- +-- Also note that "ProgGenSF" depends on hard use of unsafe* stuff, so if there is a bug, it may segfault.... + +type ExpTrie e = IORef (FMType (Array Int [e])) +-- type ExpTrie e = MapType (ExpMatrix e) -- PGSF, PGSFIO¤À¤È¤³¤Ã¤Á¤À¤Ã¤¿¡¥ + +type TypeTrie = MapType (Matrix (Type, Subst, TyVar)) + +filtBFm cmn ty | classify = inconsistentDBTToRcT . fmap fromAnnExpr . filterDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . mapDepthDB uniqSorter + | otherwise = dbtToRcT . mapDepthDB uniqSorter + +lmtty mt fty = traceTy fty $ + lookupMT mt fty + +--memocond i = 3 map (toAnnExpr $ reducer $ extractCommon px) es) $ dbtToRcT $ unifyingPossibilitiesIO ty px +instance Expression e => WithCommon (PGSFIOR e) where + extractCommon (PGSFIOR _ (_,_,_,cmn)) = cmn + +unifyingPossibilitiesIO ty pg = unPS (unifyableExprsIO pg [] ty) emptySubst 0 + + +type MemoDeb e = (ClassLib e, TypeTrie, (([[Prim]],[[Prim]]),([[Prim]],[[Prim]])), Common) + +mkTrieOptSF :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> MemoDeb CoreExpr +mkTrieOptSF cmn classes txsopt txs + = let memoDeb = (mkCL cmn classes, typeTrie, (qtlopt,qtl), cmn) + typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb ty)) + in memoDeb + where qtlopt = splitPrimss txsopt + qtl = splitPrimss txs +-- Èó¸úΨ¤À¤±¤É¡¤DBoundT¤ËÌ·½â¤¬¤¢¤Ã¤Æ¤â¤¤¤¤¤ä¤Ä¡¥ +inconsistentDBTToRcT :: (Functor m, Monad m, Ord a) => DBoundT m a -> RecompT m a +inconsistentDBTToRcT (DBT f) = RcT $ \d -> do tss <- mapM f [0..d-1] + ts <- f d + return $ foldl (diffSortedBy compare) (map fst ts) (map (map fst) tss) +-- what to memoize about exptrie +computeExpTip :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr +computeExpTip md@(PGSFIOR _ (_,_,_,cmn)) ty = filtBFm cmn ty $ matchFunctionsIO md ty + +mkMTty = mkMT +mkMTexp = mkMT + +mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depth¤Èɽ¼¨¤¹¤ë¤Ê¤é+1¤¹¤ë¤Ù¤­¤Ç¤¢¤Ã¤¿¡¥(0¤«¤é»Ï¤Þ¤ë¤Î¤Ç) + + +type BFT = Recomp +unBFM = unMx + + +freezePS :: Type -> PriorSubsts Recomp Type -> Matrix (Type,Subst,TyVar) +freezePS ty ps + = let mxty = maxVarID ty + in mapDepth tokoro10ap $ toMx $ fmap fst $ Rc $ unDB $ fromRc $ unPS ps emptySubst (mxty+1) + +tokoro10ap :: [(Type,s,i)] -> [(Type,s,i)] +tokoro10ap = M.elems . M.fromListWith const . map (\ t@(ty,_,_) -> (ty, t)) + + + + +specializedTypes :: (Search m) => MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m ([Type],Type) +specializedTypes memodeb avail t = do specializedCases memodeb avail t + subst <- getSubst + return (map (apply subst) avail, apply subst t) +-- specializedCases is the same as unifyableExprs, except that the latter returns PriorSubsts BF [CoreExpr], and that the latter considers memodepth. +specializedCases, specCases, specCases' :: (Search m) => MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m () +specializedCases memodeb = applyDo (specCases memodeb) +specCases memodeb = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail) +{- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ +specCases memodeb avail (t0:->t1) = specCases memodeb (t0 : avail) t1 +specCases memodeb avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail +-} + + + + + +uniExprs_ :: (Search m) => MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m () +uniExprs_ memodeb avail t + = convertPS fromRc $ psListToPSRecomp lfp + where lfp depth + | memocond depth = lookupUniExprs memodeb avail t depth >> return () + | otherwise = makeUniExprs memodeb avail t depth >> return () + +lookupUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] Type +lookupUniExprs memodeb@(_,mt,_,_) avail t depth + = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t + +makeUniExprs :: MemoDeb CoreExpr -> [Type] -> Type -> Int -> PriorSubsts [] Type +makeUniExprs memodeb avail t depth + = convertPS tokoro10fst $ + do psRecompToPSList (reorganize_ (\av -> specCases' memodeb av t) avail) depth + sub <- getSubst + return $ quantify (apply sub $ popArgs avail t) + + +-- entry point for memoization +specTypes :: (Search m) => MemoDeb CoreExpr -> Type -> PriorSubsts m Type +specTypes memodeb ty + = do let (avail,t) = splitArgs ty + reorganize_ (\av -> specCases' memodeb av t) avail +-- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× + typ <- applyPS ty + return (normalize typ) + + +-- specCases' trie prims@(primgen,primmono) avail reqret = msum (map (retMono.fromPrim) primmono) `mplus` msum (map retMono fromAvail ++ map retGen primgen) +specCases' memodeb@(CL classLib, ttrie, (prims@(primgen,primmono),_),cmn) avail reqret + = mapSum retPrimMono primmono `mplus` msum (map retMono avail) `mplus` mapSum retGen primgen + where fas | constrL $ opt cmn = funApSub_ clbehalf lltbehalf behalf + | otherwise = funApSub_spec clbehalf behalf + where behalf = specializedCases memodeb avail + lltbehalf = flip mguAssumptions_ avail + clbehalf ty = mguPrograms classLib [] ty >> return () + -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () + retPrimMono (arity, retty, numtvs, _xs:::ty) + = napply arity delayPS $ + do tvid <- reserveTVars numtvs + mguPS reqret (mapTV (tvid+) retty) + fas (mapTV (tvid+) ty) + -- retMono :: Type -> PriorSubsts BFT () + retMono ty = napply (getArity ty) delayPS $ + do mguPS reqret (getRet ty) + fas ty + -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () + retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $ + do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë + -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤­¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡© + -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« + mkSubsts (tvndelay $ opt cmn) tvid reqret + fas (mapTV (tvid+) ty) + + gentvar <- applyPS (TV tvid) + + guard (orderedAndUsedArgs gentvar) + fas gentvar + +type Generator m e = PGSFIOR e -> [Type] -> Type -> PriorSubsts m [e] + +unifyableExprsIO :: Generator (DBoundT IO) CoreExpr +unifyableExprsIO memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrieIO memodeb))) + +memocondexp _ d = 0 Type -> DBoundT IO ([CoreExpr], Subst, TyVar) +lookupTypeTrieIO md@(PGSFIOR _ (_, mt, _, _)) t + = DBT $ \db -> fmap concat $ mapM (procTup md db) $ unMx (lmtty mt t) !! db +procTup :: PGSFIOR CoreExpr -> Int -> (Type, Subst, TyVar) -> IO [(([CoreExpr],Subst,TyVar),Int)] +procTup md db (ty, s, i) = mapM (\depth -> unRcT (lookupReorganizedIO md ty) depth >>= \ys -> return ((ys, s, i), db-depth)) [0..db] +{- +lookupTypeTrieRcIO :: Expression e => MemoDeb e -> Type -> RecompT IO ([e], Subst, Int) +lookupTypeTrieRcIO md@((mt,_), _, _) t + = RcT $ \d -> mapM (procTupRc md d) $ unMx (lmtty mt t) !! d +procTupRc md d (ty, s, i) = do mx <- lmtIO md ty + return (unMx mx !! d, s, i) +-} + +lookupReorganizedIO md typ = let (avs, retty) = splitArgs $ normalize typ + in reorganizerId' (\av -> lmtIO md $ popArgs av retty) avs + +-- ¥Û¥ó¥È¤ÏProgGenSF¤Îmt¤ò»È¤Ã¤¿¤Û¤¦¤¬Â®¤¤¤Ï¤º¡¥ +lmtIO :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr +lmtIO md@(PGSFIOR fmtref (_,_,_,cmn)) ty = memoRTIO fmtref (computeExpTip md) ty + +memoRTIO :: (Expression e) => ExpTrie e -> (Type -> RecompT IO e) -> Type -> RecompT IO e +memoRTIO fmtref compute ty + = RcT $ \depth -> if memocondexp ty depth then ensureAtHand fmtref compute ty depth + else unRcT (compute ty) depth + +ensureAtHand fmtref compute ty depth + = do fmt <- readIORef fmtref + case lookupFMT ty fmt of + Nothing -> makeAtHand fmtref compute ty depth + Just ar | inRange (bounds ar) depth -> return $ ar!depth + | otherwise -> makeAtHand fmtref compute ty depth + +makeAtHand fmtref compute ty depth = do result <- unRcT (compute ty) depth + if memocondexp ty (depth-1) then do ensureAtHand fmtref compute ty (depth-1) +{- + modifyIORef fmtref (fst . addToLast ty depth result) + return result +-} + atomicModifyIORef fmtref (addToLast ty depth result) +{- + else do modifyIORef fmtref (fst . mkSingle ty depth result) + return result +-} + else atomicModifyIORef fmtref (mkSingle ty depth result) +-- exptip¤òlookup¤¹¤ë¤È¤­¤ânormalize¤¹¤Ù¤­¡¥¤È»×¤Ã¤¿¤±¤É¡¤typetip¤Ë¤¢¤ëtype¤Ïnormalize¤µ¤ì¤Æ¤ë¡¥ + +addToLast :: Expression e => Type -> Int -> [e] -> FMType (Array Int [e]) -> (FMType (Array Int [e]), [e]) +addToLast ty depth result fmt = (updateFMT upd (error "addToLast: cannot happen") ty fmt, result) + where upd ar = array (lo,depth) ((depth,result) : assocs ar) + where (lo,_hi) = bounds ar +mkSingle :: Expression e => Type -> Int -> [e] -> FMType (Array Int [e]) -> (FMType (Array Int [e]), [e]) +mkSingle ty depth result fmt = (updateFMT (error "mkSingle: I think this cannot happen") (array (depth,depth) [(depth,result)]) ty fmt, result) + + +{- +modify :: Type -> Int -> FMType (Array Int [AnnExpr]) -> (FMType (Array Int [AnnExpr]), [AnnExpr]) +modify ty depth fmt + = case lookupFMT fmt ty of + Nothing -> do result <- compute ¤Ã¤Æ¤³¤È¤Ï, IO ¤¬´Ö¤ËÆþ¤ë¤Î¤Ç, atomic ¤Ç¤Ï¤Ê¤¤. + +atomic¤«¤É¤¦¤«¤Ï¸å¤Ç¹Í¤¨¤ë¡¥ + +Íפϡ¤ +¡¦³ºÅö²Õ½ê¤¬memoÂоݤǤʤ¤¾ì¹ç¡¤compute¤·¤Æ½ªÎ»¡¥ + memoÂоݤξì¹ç(X)¡¤memo¤Ë¤¢¤ë¤Ê¤é¡¤¤½¤ì¤ò¼è¤Ã¤Æ¤­¤Æ½ªÎ»¡¥ + ¤Ê¤¤¤Î¤Ç¤¢¤ì¤Ð¡¤{result <- compute; + ³ºÅö²Õ½ê¤Î1¸ÄÀõ¤¤¤È¤³¤í¤¬memoÂоݤǤʤ¤¾ì¹ç¡¤³ºÅö²Õ½ê¤Î¤ß¤ò¤â¤Äsingleton array¤ò½ñ¤­¹þ¤ó¤Ç½ªÎ»(A) + memoÂоݤʤ顤{(X)¤ò£±¤³Àõ¤¤¤È¤³¤í¤Ç¼Â¹Ô¡Ê·ë²Ì¤Ï¼Î¤Æ¡Ë; + ¡Ê£±¸ÄÀõ¤¤¤È¤³¤í¤Þ¤Ç¤Îarray¤¬¤Ç¤­¤Æ¤ë¤Î¤Ç¡¤¡Ë³ºÅö²Õ½ê¤òËöÈø¤Ë²Ã¤¨¤Æ½ªÎ»(B)}} + +atomically¤Ë¤ä¤ë¤Î¤Ï(A)¤È(B)¤À¤±¤«¡¥atomicModifyIORef :: IORef a -> (a -> (a, b)) -> IO b +¼Â¤Ïmemocondexp¤Ç(memodepth¤Ê¤·¤Ç)¤Ç¤­¤½¤¦¡¥ +´Ø¿ô(X)¤¬ËܼÁŪ¡¥loop¤¹¤ë¤Î¤Ç¡¥(X)¤òensureAtHand¤È¤¤¤¦Ì¾Á°¤Ë¡¥ +-} + + + +-- entry for memoization +matchFunctionsIO :: PGSFIOR CoreExpr -> Type -> DBoundT IO CoreExpr +matchFunctionsIO memodeb ty = case splitArgs (saferQuantify ty) of (avail,t) -> matchFunsIO memodeb avail t + +-- saferQuantify ty = let offset = maxVarID (unquantify ty) + 1 in quantify' $ mapTV (offset+) ty + +matchFunsIO :: PGSFIOR CoreExpr -> [Type] -> Type -> DBoundT IO CoreExpr +matchFunsIO memodeb avail reqret = catBags $ runPS (matchFuns' unifyableExprsIO memodeb avail reqret) + +matchFuns' :: (Search m) => Generator m CoreExpr -> Generator m CoreExpr +-- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDeb¤Î·¿¤Î°ã¤¤¤Ç¤³¤ì¤Ï¤¦¤Þ¤¯¤¤¤«¤Ê¤ó¤À¡¥ +matchFuns' rec md@(PGSFIOR _ (CL classLib, _, (_,(primgen,primmono)),cmn)) avail reqret + = let clbehalf = mguPrograms classLib [] + behalf = rec md avail + lltbehalf = lookupListrie lenavails rec md avail -- heuristic filtration + lenavails = length avail +-- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration + fe = filtExprs (guess $ opt cmn) + in fromAssumptions cmn lenavails behalf (\a b -> guard $ a==b) reqret avail `mplus` + mapSum (retPrimMono cmn lenavails clbehalf lltbehalf behalf matchPS reqret) primmono `mplus` + mapSum (( if tv0 $ opt cmn then retGenTV0 else + if tv1 $ opt cmn then retGenTV1 else retGenOrd) cmn lenavails fe clbehalf lltbehalf behalf reqret) primgen + +lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e +lookupListrie lenavails rec memodeb@(PGSFIOR _ (_,_,_,cmn)) avail t + | constrL opts = matchAssumptions cmn lenavails t avail + | guess opts = do + args <- rec memodeb avail t + let args' = filter (not.isClosed.toCE) args + when (null args') mzero + return args' + | otherwise = do + args <- rec memodeb avail t + let args' = filter (not.isConstrExpr.toCE) args + when (null args') mzero + return args' + where opts = opt cmn + +\end{code} diff --git a/MagicHaskeller/ProgramGenerator.lhs b/MagicHaskeller/ProgramGenerator.lhs --- a/MagicHaskeller/ProgramGenerator.lhs +++ b/MagicHaskeller/ProgramGenerator.lhs @@ -3,7 +3,7 @@ -- \begin{code} -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS -cpp #-} module MagicHaskeller.ProgramGenerator where import MagicHaskeller.Types @@ -13,7 +13,7 @@ import MagicHaskeller.CoreLang import Control.Monad.Search.Combinatorial import MagicHaskeller.PriorSubsts -import Data.List(partition, sortBy) +import Data.List(partition, sortBy, genericLength) import Data.Ix(inRange) import MagicHaskeller.Instantiate @@ -32,44 +32,56 @@ import MagicHaskeller.Options +import Data.Array + -- replacement of LISTENER. Now replaced further with |guess| -- listen = False -- | annotated 'Typed [CoreExpr]' -type Prim = (Int, Type, Int, Typed [CoreExpr]) +type Prim = (Int, Type, TyVar, Typed [CoreExpr]) +class WithCommon a where + extractCommon :: a -> Common + -- | ProgramGenerator is a generalization of the old @Memo@ type. -class ProgramGenerator a where +class WithCommon a => ProgramGenerator a where -- | |mkTrie| creates the generator with the default parameters. - mkTrie :: Common -> [[Typed [CoreExpr]]] -> a - mkTrie cmn t = mkTrieOpt cmn t t - mkTrieOpt :: Common -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a - mkTrieOpt cmn _ t = mkTrie cmn t + mkTrie :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> a + mkTrie cmn c t = mkTrieOpt cmn c t t + mkTrieOpt :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a + mkTrieOpt cmn c _ t = mkTrie cmn c t -- error "This program generator does not take an optional primitive set." - matchingPrograms, unifyingPrograms :: Search m => Type -> a -> m AnnExpr + matchingPrograms, matchingProgramsWOAbsents, unifyingPrograms :: Search m => Type -> a -> m AnnExpr matchingPrograms ty memodeb = unifyingPrograms (quantify ty) memodeb + matchingProgramsWOAbsents ty memodeb = mapDepth (filter (not . isAbsent (getArity ty) . toCE)) $ matchingPrograms ty memodeb +class WithCommon a => ProgramGeneratorIO a where + -- | |mkTrie| creates the generator with the default parameters. + mkTrieIO :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> IO a + mkTrieIO cmn c t = mkTrieOptIO cmn c t t + mkTrieOptIO :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO a + mkTrieOptIO cmn c _ t = mkTrieIO cmn c t + -- error "This program generator does not take an optional primitive set." -- | Use memoization requiring IO matchingProgramsIO, unifyingProgramsIO :: Type -> a -> RecompT IO AnnExpr -- Should I define SearchT? matchingProgramsIO ty memodeb = unifyingProgramsIO (quantify ty) memodeb - unifyingProgramsIO = unifyingPrograms -- Another option might be to create @newtype MemoToFile = NT (RecompT (StateT Params IO))@, and define @instance Search MemoToFile@. One drawback of this approach is that @Params@ is separated from @Options@. - extractCommon :: a -> Common -extractTCL :: ProgramGenerator a => a -> TyConLib +extractTCL :: WithCommon a => a -> TyConLib extractTCL = tcl . extractCommon -extractVL :: ProgramGenerator a => a -> VarLib +extractVL :: WithCommon a => a -> VarLib extractVL = vl . extractCommon -extractRTrie :: ProgramGenerator a => a -> RTrie +extractRTrie :: WithCommon a => a -> RTrie extractRTrie = rt . extractCommon -reducer :: ProgramGenerator a => a -> CoreExpr -> Dynamic -reducer pg = execute (opt $ extractCommon pg) (extractVL pg) +reducer :: Common -> CoreExpr -> Dynamic +reducer cmn = execute (opt cmn) (vl cmn) -data Common = Cmn {opt :: Opt (), tcl :: TyConLib, vl :: VarLib, rt :: RTrie} +data Common = Cmn {opt :: Opt (), tcl :: TyConLib, vl :: VarLib, pvl :: VarLib, rt :: RTrie} -mkCommon :: Options -> [Primitive] -> Common -mkCommon opts prims = let - tyconlib = primitivesToTCL prims +mkCommon :: Options -> [Primitive] -> [Primitive] -> Common +mkCommon opts totals partials = + let + tyconlib = primitivesToTCL totals optunit = forget opts - in Cmn {opt = optunit, tcl = tyconlib, vl = primitivesToVL tyconlib prims, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)} + in Cmn {opt = optunit, tcl = tyconlib, vl = primitivesToVL tyconlib totals, pvl = primitivesToVL tyconlib partials, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)} -- | options for limiting the hypothesis space. type Options = Opt [[Primitive]] @@ -78,7 +90,7 @@ retsTVar _ = False annotateTCEs :: Typed [CoreExpr] -> Prim -annotateTCEs tx@(_:::t) = (getArity t, getRet t, maxVarID t + 1, tx) +annotateTCEs tx@(_:::t) = (getArity t, getRet t, maxVarID t + 1, tx) -- getArity returns the shorter arity that does not count contexts. splitPrims :: [Typed [CoreExpr]] -> ([Prim],[Prim]) splitPrims = partition retsTVar . map annotateTCEs @@ -111,18 +123,18 @@ wind_ = wind id -{-# SPECIALIZE fromAssumptions :: (Search m, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-} -fromAssumptions :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [e] -fromAssumptions pg lenavails behalf mps reqret avail = msum $ map (retMono pg lenavails behalf (flip mps reqret)) (fromAvail avail) +{-# SPECIALIZE fromAssumptions :: (Search m) => Common -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-} +fromAssumptions :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [e] +fromAssumptions cmn lenavails behalf mps reqret avail = msum $ map (retMono cmn lenavails behalf (flip mps reqret)) (fromAvail avail) -retMono :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ()) -> ([CoreExpr], (Int,[Type],Type)) -> PriorSubsts m [e] -retMono pg lenavails behalf tok fromBlah - = do let (es, (arity,args,retty)) = fromBlah +retMono :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ()) -> (Int8, (Int8,[Type],Type)) -> PriorSubsts m [e] +retMono cmn lenavails behalf tok fromBlah + = do let (n, (arity,args,retty)) = fromBlah tok retty - convertPS (ndelay arity) $ - fap behalf args (map (mkHead (reducer pg) lenavails arity) es) -fromAvail :: [Type] -> [([CoreExpr], (Int,[Type],Type))] -fromAvail = zipWith (\ n t -> ([X n], revSplitArgs t)) [0..] + convertPS (ndelay $ fromIntegral arity) $ + fap behalf args (map (mkHead (reducer cmn) lenavails arity) [X n]) +fromAvail :: [Type] -> [(Int8, (Int8,[Type],Type))] +fromAvail = zipWith (\ n t -> (n, revSplitArgs t)) [0..] -- ConstrL$B$G$O(Bmatch$B$G$O%@%a!%M}M3$O(BDec. 2, 2007$B$N(Bnotes$B$r;2>H!%(B @@ -130,12 +142,12 @@ mguAssumptions patty assumptions = applyDo mguAssumptions' assumptions patty mguAssumptions' assumptions patty = msum $ zipWith (\n t -> mguPS patty t >> return [X n]) [0..] assumptions -{-# SPECIALIZE matchAssumptions :: (MonadPlus m, ProgramGenerator pg) => pg -> Int -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-} -matchAssumptions :: (MonadPlus m, Expression e, ProgramGenerator pg) => pg -> Int -> Type -> [Type] -> PriorSubsts m [e] -matchAssumptions pg lenavails reqty assumptions +{-# SPECIALIZE matchAssumptions :: (MonadPlus m) => Common -> Int -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-} +matchAssumptions :: (MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m [e] +matchAssumptions cmn lenavails reqty assumptions = do s <- getSubst let newty = apply s reqty - msum $ zipWith (\n t -> matchPS newty t >> return [mkHead (reducer pg) lenavails (getArity newty) (X n)]) [0..] assumptions + msum $ zipWith (\n t -> matchPS newty t >> return [mkHead (reducer cmn) lenavails (getLongerArity newty) (X n)]) [0..] assumptions -- match $B$N>l9g!$DL>o$O(Breqty$B$NJ}$@$1(Bapply subst$B$9$l$P$h$$!%(B -- not sure if this is more efficient than doing mguAssumptions and returning (). @@ -143,21 +155,28 @@ mguAssumptions_ patty assumptions = applyDo mguAssumptions_' assumptions patty mguAssumptions_' assumptions patty = msum $ map (mguPS patty) assumptions -{-# SPECIALIZE retPrimMono :: (Search m, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-} -retPrimMono :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [e] -retPrimMono pg lenavails lltbehalf behalf mps reqret (arity, retty, numtvs, xs:::ty) + +{-# SPECIALIZE retPrimMono :: (Search m) => Common -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-} +retPrimMono :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [e] +retPrimMono cmn lenavails clbehalf lltbehalf behalf mps reqret (arity, retty, numtvs, xs:::ty) = do tvid <- reserveTVars numtvs mps (mapTV (tvid+) retty) reqret - convertPS (ndelay arity) $ - funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer pg) lenavails arity) xs) -funApSub :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> [e] -> PriorSubsts m [e] + convertPS (ndelay $ fromIntegral arity) $ + funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs) +funApSub :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> [e] -> PriorSubsts m [e] funApSub = funApSubOp (<$>) -funApSubOp op lltbehalf behalf (t:> ts) funs = do args <- lltbehalf t - funApSubOp op lltbehalf behalf ts (liftM2 op funs args) --- original. -funApSubOp op lltbehalf behalf (t:->ts) funs = do args <- behalf t - funApSubOp op lltbehalf behalf ts (liftM2 op funs args) -funApSubOp _ _ _ _ funs = return funs +funApSubOp op clbehalf lltbehalf behalf = faso + where faso (t:=>ts) funs + = do args <- clbehalf t + faso ts (liftM2 op funs args) + faso (t:> ts) funs + = do args <- lltbehalf t + faso ts (liftM2 op funs args) + -- original. + faso (t:->ts) funs + = do args <- behalf t + faso ts (liftM2 op funs args) + faso _ funs = return funs -- original$B$G(BrevGetArgs$B7PM3$K$9$k$H!$(BfoldM$B$r;H$C$?>l9g$HF1$88zN($K$J$k!%(B {- funApSub behalf t funs = fap behalf (revGetArgs t) funs @@ -185,22 +204,23 @@ mapAndFoldM op (n `op` y) f xs -{-# SPECIALIZE retGen :: (Search m, ProgramGenerator pg) => pg -> Int -> (Type -> Type -> [CoreExpr] -> [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-} + +{-# SPECIALIZE retGen :: (Search m) => Common -> Int -> (Type -> Type -> [CoreExpr] -> [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-} retGen, retGenOrd, retGenTV1 - :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> Type -> [e] -> [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> Prim -> PriorSubsts m [e] -retGen pg lenavails fe lltbehalf behalf = retGen' (funApSub lltbehalf behalf) pg lenavails fe lltbehalf behalf -retGen' fas pg lenavails fe lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) - = convertPS (ndelay arity) $ + :: (Search m, Expression e) => Common -> Int -> (Type -> Type -> [e] -> [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> Prim -> PriorSubsts m [e] +retGen cmn lenavails fe clbehalf lltbehalf behalf = retGen' (funApSub clbehalf lltbehalf behalf) cmn lenavails fe clbehalf lltbehalf behalf +retGen' fas cmn lenavails fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) + = convertPS (ndelay $ fromIntegral arity) $ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>! _) funs = mzero -- mkSubsts$B$GF3F~$5$l$?(Btyvars$B$,;H$o$l$F$$$J$$%1!<%9!%(Breplace$B$5$l$?7k2L(BTV$B$C$F%1!<%9$O$H$j$"$($:L5;k(B.... funApSub'' filtexp (t:->ts@(u:->_)) funs @@ -223,27 +243,31 @@ usedArg n (TV m :-> _) = n /= m usedArg _ _ = True -retGenTV1 pg lenavails fe lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) - = convertPS (ndelay arity) $ +retGenTV1 cmn lenavails fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) + = convertPS (ndelay $ fromIntegral arity) $ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!! Bool -> Type -> Type -> [e] -> [e] +filtExprs g a b | g = filterExprs a b + | otherwise = id + -- LISTENER$B$+(BDESTRUCTIVE$B$,(Bdefine$B$5$l$F$$$k$H$-$N!$3F%1!<%9$N(Boptimization filterExprs :: Expression e => Type -> Type -> [e] -> [e] filterExprs gentvar ty = filter (cond . getArgExprs . toCE) @@ -327,8 +351,10 @@ isConstrExpr (X _) = False isConstrExpr (Lambda _) = False +isConstrExpr (Context _) = False isConstrExpr (f :$ _) = isConstrExpr f -isConstrExpr (Primitive _ b) = b +isConstrExpr (Primitive _) = False +isConstrExpr (PrimCon _) = True isClosed = isClosed' 0 isClosed' dep (X n) = n < dep @@ -385,7 +411,7 @@ isUsed _ _ = False -mkSubsts :: Search m => Int -> Int -> Type -> PriorSubsts m Int +mkSubsts :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int8 mkSubsts n tvid reqret = base `mplus` ndelayPS n recurse where base = do updatePS (unitSubst tvid reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B @@ -394,7 +420,7 @@ arity <- mkSubsts n tvid (TV v :-> reqret) return (arity+1) -mkSubst :: Search m => Int -> Int -> Type -> PriorSubsts m Int +mkSubst :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int8 mkSubst n tvid reqret = base `mplus` ndelayPS n first where base = do updatePS (unitSubst tvid reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B @@ -427,6 +453,23 @@ areMono = all (null.tyvars) + +combs 0 xs = [[]] +combs n xs = [] : [ y:zs | y:ys <- tails xs, zs <- combs (n-1) ys ] +tails [] = [] +tails xs@(_:ys) = xs : tails ys + +mapFst3 f (ces, s, i) = (f ces, s, i) +decodeVarsPos vs = mapFst3 (map (decodeVarsCE vs)) + +decodeVarsCE :: [Int8] -> CoreExpr -> CoreExpr +decodeVarsCE vs = decodeVarsCE' 0 (listArray (0, genericLength vs-1) vs) +decodeVarsCE' :: Int8 -> Array Int8 Int8 -> CoreExpr -> CoreExpr +decodeVarsCE' offset ar e@(X n) = let nn = n - offset + in if inRange (bounds ar) nn then X $ (ar ! nn) + offset else e +decodeVarsCE' offset ar (Lambda e) = Lambda $ decodeVarsCE' (offset + 1) ar e +decodeVarsCE' offset ar (f :$ e) = decodeVarsCE' offset ar f :$ decodeVarsCE' offset ar e +decodeVarsCE' offset ar e = e \end{code} diff --git a/MagicHaskeller/ReadTHType.lhs b/MagicHaskeller/ReadTHType.lhs --- a/MagicHaskeller/ReadTHType.lhs +++ b/MagicHaskeller/ReadTHType.lhs @@ -3,7 +3,7 @@ -- \begin{code} -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS -cpp #-} module MagicHaskeller.ReadTHType(thTypeToType, typeToTHType, showTypeName, plainTV, unPlainTV) where import MagicHaskeller.Types as Types @@ -19,29 +19,32 @@ -- MyDynamic‚Å‚µ‚©Žg‚í‚ê‚Ä‚¢‚È‚¢‚̂ŁCForallT‚Í’P‚É–³Ž‹‚·‚éDPolyDynamic‚̃`ƒFƒbƒN‚ª‚¿‚å‚Á‚ÆŠÉ‚­‚Ȃ邾‚¯D thTypeToType :: TyConLib -> TH.Type -> Types.Type -thTypeToType tcl t = normalize $ thTypeToType' tcl t -thTypeToType' tcl (ForallT _ [] t) = thTypeToType' tcl t -thTypeToType' tcl (ForallT _ (_:_) t) = error "Type classes are not supported yet." -thTypeToType' tcl (TupleT n) = TC (tuple tcl n) -thTypeToType' tcl ListT = TC (list tcl) +thTypeToType tcl t = normalize $ thTypeToType' tcl [] t +thTypeToType' tcl vs (ForallT bs [] t) = thTypeToType' tcl (vs++map tyVarBndrToName bs) t +thTypeToType' tcl _ (ForallT _ (_:_) t) = error "Type classes are not supported yet." +thTypeToType' tcl _ (TupleT n) = TC (tuple tcl n) +thTypeToType' tcl _ ListT = TC (list tcl) -- thTypeToType' tcl (HsTyFun ht0 ht1) -- = thTypeToType' tcl ht0 :-> thTypeToType' tcl ht1 -thTypeToType' tcl (AppT (AppT ArrowT ht0) ht1) = thTypeToType' tcl ht0 :-> thTypeToType' tcl ht1 -thTypeToType' tcl (AppT (AppT (ConT name) ht0) ht1) | nameBase name == "(->)" = thTypeToType' tcl ht0 :> thTypeToType' tcl ht1 -thTypeToType' tcl (AppT ht0 ht1) = TA (thTypeToType' tcl ht0) (thTypeToType' tcl ht1) -thTypeToType' (fm,_) (ConT name) = let nstr = showTypeName name - in case Data.Map.lookup nstr fm of - Nothing -> TC $ (-1 - bakaHash nstr) -- error "nameToTyCon: unknown TyCon" - Just c -> TC c +thTypeToType' tcl vs (AppT (AppT ArrowT ht0) ht1) = thTypeToType' tcl vs ht0 :-> thTypeToType' tcl vs ht1 +thTypeToType' tcl vs (AppT (AppT (ConT name) ht0) ht1) | nameBase name == "(->)" = thTypeToType' tcl vs ht0 :> thTypeToType' tcl vs ht1 +thTypeToType' tcl vs (AppT ht0 ht1) = TA (thTypeToType' tcl vs ht0) (thTypeToType' tcl vs ht1) +thTypeToType' (fm,_) _ (ConT name) = let nstr = showTypeName name + in case Data.Map.lookup nstr fm of + Nothing -> -- TC $ (-1 - bakaHash nstr) + error $ "thTypeToType' : "++nstr++" : unknown TyCon" + Just c -> TC c {- ‚±‚Ì•Ó‚Í’P‚È‚éƒRƒƒ“ƒgƒAƒEƒg‚Å‚¢‚¢‚ñ‚¾‚Á‚¯H thTypeToType' tcl (HsTyCon (Special HsUnitCon)) = TC (unit tcl) thTypeToType' tcl (HsTyCon (Special HsListCon)) = TC (list tcl) -} -thTypeToType' _ ArrowT = error "Partially applied (->)." -thTypeToType' _ (VarT name) = nameToVarType name +thTypeToType' _ _ ArrowT = error "Partially applied (->)." +thTypeToType' _ vs (VarT name) = TV $ case Prelude.lookup name $ zip vs [0..] of Nothing -> error "thTypeToType : unbound type variable" + Just i -> i -- thTypeToType' _ hst = error ("thTypeToType': "++show hst) -nameToVarType name = strToVarType (showTypeName name) +tyVarBndrToName (PlainTV name) = name +tyVarBndrToName (KindedTV name _) = name {- tcKind‚ð”pŽ~‚·‚é‚̂ŁD‚܁CtcKind‚ª‚È‚­‚Ä‚àhigher-order kind‚Å‚È‚¯‚ê‚΃gƒbƒvƒŒƒxƒ‹‚Ìkind‚©‚琄˜_‚Å‚«‚邵D -- copied from svn/MagicHaskeller/memodeb/RandomFilter.hs @@ -60,7 +63,7 @@ tvs -> TH.ForallT (map (plainTV . tvToName) $ nub tvs) []) (typeToTHType' tcl 0 ty) typeToTHType' (_,ar) k (TC tc) | tc >= 0 = if name == "[]" then ListT else TH.ConT (TH.mkName name) - where name = if inRange (bounds ar) k then fst ((ar ! k) !! tc) + where name = if inRange (bounds ar) k then fst ((ar ! k) !! fromIntegral tc) else 'K':shows k ('I':show tc) -- useful with defaultTCL typeToTHType' tcl _ (TV tv) = TH.VarT $ tvToName tv typeToTHType' tcl k (TA t0 t1) = TH.AppT (typeToTHType' tcl (k+1) t0) (typeToTHType' tcl 0 t1) diff --git a/MagicHaskeller/ReadTypeRep.hs b/MagicHaskeller/ReadTypeRep.hs --- a/MagicHaskeller/ReadTypeRep.hs +++ b/MagicHaskeller/ReadTypeRep.hs @@ -1,6 +1,7 @@ -- -- (c) Susumu Katayama -- +{-# LANGUAGE CPP #-} module MagicHaskeller.ReadTypeRep where import Data.Typeable import MagicHaskeller.Types as Types @@ -10,15 +11,20 @@ import qualified Language.Haskell.TH as TH +#if __GLASGOW_HASKELL__ < 700 +tyConName = tyConString +#endif +{- mkTyCon is now obsolete. typeToTR :: TyConLib -> Type -> TypeRep typeToTR tcl ty = tyToTR tcl 0 ty tyToTR :: TyConLib -> Kind -> Type -> TypeRep tyToTR _ 0 (TV _) = typeOf 'c' -- ¤á¤ó¤É¤¯¤µ¤¤¤Î¤Ç¤È¤ê¤¢¤¨¤ºChar -tyToTR (_,ar) k (TC tc) | tc >= 0 = mkTyConApp (mkTyCon $ fst ((ar!k) !! tc)) [] +tyToTR (_,ar) k (TC tc) | tc >= 0 = mkTyConApp (mkTyCon $ fst ((ar!k) !! fromIntegral tc)) [] | otherwise = error "tyToTR: impossible (tc<0)." tyToTR tcl k (TA a b) = mkAppTy (tyToTR tcl (k+1) a) (tyToTR tcl 0 b) tyToTR tcl 0 (a :-> b) = mkFunTy (tyToTR tcl 0 a) (tyToTR tcl 0 b) +-} -- ¤È¤ê¤¢¤¨¤º¤ÏFake¤Ç¤Ê¤¤Dynamic¤Ç¤Îtype check¤Ë»È¤¦¤À¤±¤Ê¤Î¤Ç¡¤¸úΨ¤Ï¹Í¤¨¤Ê¤¯¤Æ¤è¤¤¡¥ -- ¤Ç¤â¤Þ¤¢¡¤monomorphic¸ÂÄê¤Ê¤éTypeRep¤ÎÊý¤¬Â®¤¤¤ß¤¿¤¤¡Ê¡©¡Ë¡¥¥½¡¼¥¹¤ò¸«¤¿´¶¤¸¡¤Æäˡ¤equality¤Ë´Ø¤·¤Æ¤Ï¸úΨŪ¤Ê¼ÂÁõ¤ò¤ä¤Ã¤Æ¤ë¤ß¤¿¤¤¡¥ @@ -43,7 +49,7 @@ ++ " and use `matching :: Int -> Memo -> TH.Type -> [[TH.Exp]]'.\n(or maybe you forgot to set a component library?)") -- fromJust Nothing = error ("tyConString = "++show (tyConString' tc) ++ ", and fst tcl = "++show (fst tcl)) -- fromJust Nothing = error (show tc ++ " does not appear in the component library. Forgot to set one? BTW tc==funTyCon is "++show (tc==funTyCon)++" and funTyCon is "++show funTyCon) - tyConString' tc = case tyConString tc of + tyConString' tc = case tyConName tc of str@(',':_) -> '(':str++")" -- tyConString mistakenly prints "," instead of "(,)". str -> unqualify str -- Use the unqualified name to avoid confusion @@ -57,13 +63,13 @@ funTyCon :: Data.Typeable.TyCon funTyCon = typeRepTyCon (mkFunTy undefTC undefTC) -- undef = error "funTyCon" -- Dunno why, but seemingly mkFunTy is strict. -undefTC = mkTyConApp (mkTyCon "Hoge") [] +undefTC = mkTyConApp (mkTyCon3 "base" "Prelude" "Hoge") [] trToTHType :: TypeRep -> TH.Type trToTHType tr = case splitTyConApp tr of (tc,trs) -> if tc == funTyCon || show tc == show funTyCon -- dunno why, but sometimes |tc==funTyCon| is not enough. then TH.AppT TH.ArrowT (trToTHType (head trs)) `TH.AppT` trToTHType (head (tail trs)) - else foldl TH.AppT (TH.ConT (TH.mkName (tyConString tc))) (map trToTHType trs) - where tyConToName str = case tyConString str of "[]" -> TH.ListT + else foldl TH.AppT (TH.ConT (TH.mkName (tyConName tc))) (map trToTHType trs) + where tyConToName str = case tyConName str of "[]" -> TH.ListT str@(',':_) -> TH.TupleT (length str) -- tyConString mistakenly prints "," instead of "(,)". str -> TH.ConT $ TH.mkName str diff --git a/MagicHaskeller/ShortString.hs b/MagicHaskeller/ShortString.hs --- a/MagicHaskeller/ShortString.hs +++ b/MagicHaskeller/ShortString.hs @@ -7,6 +7,8 @@ import Data.Char import MagicHaskeller.CoreLang import MagicHaskeller.Types +import Data.Int +import Data.Word -- LC.cons' ¤À¤È¿ʬ¥À¥á @@ -33,25 +35,41 @@ instance ShortString CoreExpr where showsBriefly (Lambda ce) = (LC.cons '\\') . showsBriefly ce showsBriefly (X i) = (LC.cons 'X') . showsBriefly i - showsBriefly (Primitive i b) = (LC.cons 'P') . showsBriefly i . showsBriefly b + showsBriefly (Primitive i) = (LC.cons 'p') . showsBriefly i + showsBriefly (PrimCon i) = (LC.cons 'P') . showsBriefly i + showsBriefly (Context _) = LC.cons 'C' showsBriefly (c :$ e) = (LC.cons '$') . showsBriefly c . showsBriefly e readsBriefly cs = case C.uncons cs of -- Int(Nat)¤È1ʸ»ú¤á°ì½ï¤Ë1¥Ð¥¤¥È¤Ë¤Ç¤­¤Ê¤¤¤«?¤¢¤È¡¤lambda¤Ï³¤¯¤Î¤Ç¤Þ¤È¤á¤é¤ì¤½¤¦¡¥ Just ('\\',xs) -> do (ce,ys) <- readsBriefly xs return (Lambda ce, ys) Just ('X', xs) -> do (i, ys) <- readsBriefly xs return (X i, ys) + Just ('p', xs) -> do (i, ys) <- readsBriefly xs + return (Primitive i, ys) Just ('P', xs) -> do (i, ys) <- readsBriefly xs - (b, zs) <- readsBriefly ys - return (Primitive i b, zs) + return (PrimCon i, ys) Just ('$', xs) -> do (c, ys) <- readsBriefly xs (e, zs) <- readsBriefly ys return (c :$ e, zs) + Just ('C', xs) -> fail "readsBriefly for classes has not been implemented. (BTW, they should be reconstructed in the implementation.)" _ -> fail "parse error" -- Only small ints are used, if I remember correctly. instance ShortString Int where showsBriefly i = LC.cons (chr (i + 128)) -- other safer options are Numeric.showHex and Numeric.showIntAtBase readsBriefly xs = case C.uncons xs of Nothing -> fail "parse error" Just (c,cs) -> return (ord c - 128, cs) +instance ShortString Int16 where -- Int8 to mattaku onaji + showsBriefly i = LC.cons (chr (fromIntegral i + 128)) + readsBriefly xs = case C.uncons xs of Nothing -> fail "parse error" + Just (c,cs) -> return (fromIntegral (ord c - 128), cs) +instance ShortString Int8 where + showsBriefly i = LC.cons (chr (fromIntegral i + 128)) + readsBriefly xs = case C.uncons xs of Nothing -> fail "parse error" + Just (c,cs) -> return (fromIntegral (ord c - 128), cs) +instance ShortString Word8 where + showsBriefly i = LC.cons (chr (fromIntegral i)) + readsBriefly xs = case C.uncons xs of Nothing -> fail "parse error" + Just (c,cs) -> return (fromIntegral (ord c), cs) instance (ShortString a, ShortString b, ShortString c) => ShortString (a,b,c) where showsBriefly (a,b,c) = showsBriefly a . showsBriefly b . showsBriefly c readsBriefly cs = do (a,ds) <- readsBriefly cs diff --git a/MagicHaskeller/SimpleServer.hs b/MagicHaskeller/SimpleServer.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/SimpleServer.hs @@ -0,0 +1,410 @@ +-- Do not forget -threaded! +-- +import MagicHaskeller.LibTH +import MagicHaskeller.LibExcel + +import GHC hiding (language) +import HscTypes(HscEnv(hsc_IC), InteractiveContext(..)) +#if __GLASGOW_HASKELL__ < 706 +import DynFlags hiding (Option, language) +#else +import DynFlags hiding (Option, Language, language) +#endif +import qualified MonadUtils as MU -- clearly distinguish MU.liftIO from Control.Monad.IO.Class.liftIO +-- import Panic (panic) +import Outputable(showPpr) +import Type + +import Language.Haskell.TH as TH +import GHC.Paths(libdir) +import Control.Concurrent +import Network +import System.IO +import System.IO.Error(isEOFError) +import Control.Exception +import Data.Char(isAlphaNum, isSpace) +import Text.Html(stringToHtmlString) + +import MagicHaskeller.ExpToHtml(QueryOptions(..), defaultQO, versionInfo, expToPlainString, expSigToString, Language(..)) + +import Unsafe.Coerce + +import MagicHaskeller.GetTime +import System.Time + +import System.Console.GetOpt +import System.Environment +import System.Exit + +import Control.Monad + +-- These are for reporting resource usage. +#if __GLASGOW_HASKELL__ >= 700 +import GHC.Stats +#endif +import System.Process(system) +import System.Mem(performGC) + +import Control.Monad.Par.Class +import Control.Monad.Par.IO +import Control.Monad.IO.Class(liftIO) + +-- import Control.Concurrent.ParallelIO(stopGlobalPool) + +-- import Data.Map + +#ifdef UNIX +-- as suggested by /usr/share/doc/libghc6-network-doc/html/Network.html +import System.Posix hiding (Default) +#endif + +-- file:///usr/share/doc/libghc6-network-doc/html/Network.html#t%3APortID +--portID = UnixSocket "mhserver" +portID = PortNumber 55443 + +trainers = "predicates" + +defaultDefault = "(Int,Integer, Double, Ratio Int, Char,(),String)" -- I guess in most cases Int will do. + +queryOut = "query.out" + +data Flag = Port PortNumber | Socket FilePath | Interactive | RunPSCommand | JustTraining + | Depth Int + | WithDoubleRatio | WithRatio | RatioOnly | WithDouble + | WithAbsents + | Default (Maybe String) + | MemoSize (Maybe Int) + | HTML | PlainText + | NoTraining | SequentialTraining FilePath | ParallelTraining FilePath + | PostProcessor String + | Excel + +cmdOpts :: [OptDescr Flag] +cmdOpts = [ Option ['p'] ["port-number"] (ReqArg (Port . toEnum . readOrErr msgp) "PORT_NUMBER") "use port number PORT_NUMBER (default, using -p 55443)" + , Option ['u'] ["unix-socket"] (ReqArg Socket "SOCKET_FILEPATH") "use socket file SOCKET_FILEPATH" + , Option ['i'] ["interactive","stdio"] (NoArg Interactive) "use the standard I/O for query and printing results" + , Option ['r'] ["run-ps-command"] (NoArg RunPSCommand) "(after training) run the ps command and exit" + , Option ['j'] ["just-training"] (NoArg JustTraining) "just training (usually for benchmarking)" + , Option ['d'] ["depth"] (ReqArg (Depth . readOrErr msgd) "SEARCH_DEPTH") $ + "search depth (" ++ shows (depth defaultQO) "by default)" + , Option ['q'] ["query-limit"] (OptArg (MemoSize . fmap (readOrErr msgd)) "QUERY_TYPE_SIZE_LIMIT") $ + "only look up the memo entries when types with size less than this value are queried. Values for other types are recomputed every time. If no value is given (default), this means there is not limit and all entry types are looked up when queried. Setting this value does not affect the time for looking up already substantiated entries. However, setting it to about 8 dramatically reduces the heap space usage, while increasing the time for training." + , Option ['b'] ["with-double-ratio"] (NoArg WithDoubleRatio) "use the library with Double-related and (Ratio Int)-related functions. This requires more memory, but fractional numbers become available" + , Option ['w'] ["with-ratio"] (NoArg WithRatio) "use the library with (Ratio Int)-related functions. This requires more memory, but fractional numbers become available" + , Option [] ["ratio-only"] (NoArg RatioOnly) "use the library only including (Ratio Int)-related functions. This is introduced for debugging, but there may be other uses." + , Option ['2'] ["with-double"] (NoArg WithDouble) "use the library with Double-related functions. This requires more memory, but fractional numbers become available" + , Option ['a'] ["absents"] (NoArg WithAbsents) "generate functions with unused arguments in addition to other useful ones" +#if __GLASGOW_HASKELL__ >= 706 + , Option [] ["default"] (OptArg Default "DEFAULT_TYPES") "default declaration for type defaulting (--default='(Int,Integer,Double, Ratio Int, Char,(),String)' by default). The outermost parens can be omitted." +#endif + , Option ['h'] ["html"] (NoArg HTML) "force printing in HTML even in the interactive mode" + , Option [] ["plain-text"] (NoArg PlainText) "force printing in plain text" + , Option ['n'] ["no-training"] (NoArg NoTraining) "start service without training beforehand" + , Option ['s'] ["sequential-training"] (ReqArg SequentialTraining "PREDICATES_FILEPATH") + "substantiate the memo table using the predicates in PREDICATES_FILEPATH. (Just setting this option would not disable parallel training. If you want to use only sequential training, use `-n -s PREDICATES_FILEPATH'.)" + , Option ['t'] ["threaded-training", + "parallel-training"] (ReqArg ParallelTraining "PREDICATES_FILEPATH") + "substantiate the memo table using the predicates in PREDICATES_FILEPATH in parallel (default, using -t 'predicates'). This option can be set along with -s, then sequential training will be done after parallel training." + , Option [] ["postprocessor"] (ReqArg PostProcessor "POSTPROCESSOR") "use POSTPROCESSOR as the postprocessor (default, using --postprocessor=postprocess). You can use --postprocessor=id to see the internal representation." + , Option ['x'] ["excel"] (NoArg Excel) "use the library for Excel synthesis, disable defaulting to integral numbers, and ppExcel as the postprocessor. You can specify `--excel --postprocessor=blah' in order to use a different postprocessor." + ] + where readOrErr msg xs = case reads xs of [(i,"")] | i>=0 -> i + _ -> error msg + msgp = "--port-number (or -p) takes a non-negative integral value specifying the port number." + msgd = "--depth (or -d) takes a non-negative integral value specifying the depth bound." + msgq = "--query-limit (or -q) takes a non-negative integral value specifying the type size bound for memoization." +readOpts :: IO ([Flag], [String]) +readOpts = do argv <- getArgs + case (getOpt Permute cmdOpts argv) of + (o,n,[] ) -> return (o,n) + (_,_,errs) -> do hPutStrLn stderr (concat errs) + usage + exitFailure +usage :: IO () +usage = do progname <- getProgName + hPutStrLn stderr $ usageInfo ("Usage: "++progname++" [OPTION...]") cmdOpts + +data HowToServe = Network PortID | STDIO | PS | NoService +data Format = DefaultFormat | ForceHTML | ForcePlain deriving Eq +data FunctionSet = PGFull | PGWithDoubleRatio | PGWithRatio | PGRatio | PGWithDouble | PGExcel +data ServerOptions = SO {howToServe :: HowToServe, queryOptions :: QueryOptions, functionSet :: FunctionSet, memoSize :: Maybe Int, defaultTypes :: Maybe String, format :: Format, sequentialTraining :: Maybe FilePath, parallelTraining :: Maybe FilePath, postprocessor :: String, language :: Language} +defaultSO = SO {howToServe = Network portID, queryOptions = defaultQO, functionSet = PGFull, memoSize = Nothing, defaultTypes = Just defaultDefault, format = DefaultFormat, sequentialTraining = Nothing, parallelTraining = Just trainers, postprocessor = "postprocess", language = LHaskell} + +procFlags :: [Flag] -> ServerOptions +procFlags = foldl procFlag defaultSO +procFlag :: ServerOptions -> Flag -> ServerOptions +procFlag st (Port i) = st{howToServe = Network (PortNumber i)} +#ifdef UNIX +procFlag st (Socket fp) = st{howToServe = Network (UnixSocket fp)} +#endif +procFlag st Interactive = st{howToServe = STDIO} +procFlag st RunPSCommand = st{howToServe = PS} +procFlag st JustTraining = st{howToServe = NoService} +procFlag st (Depth d) = st{queryOptions = (queryOptions st){depth = d}} +procFlag st (MemoSize m) = st{memoSize = m} +procFlag st WithDoubleRatio = st{functionSet = PGWithDoubleRatio} +procFlag st WithRatio = st{functionSet = PGWithRatio} +procFlag st RatioOnly = st{functionSet = PGRatio} +procFlag st WithDouble = st{functionSet = PGWithDouble} +procFlag st WithAbsents = st{queryOptions = (queryOptions st){absents = True}} +#if __GLASGOW_HASKELL__ >= 706 +procFlag st (Default ms) = st{defaultTypes = ms} +procFlag st Excel = st{defaultTypes = Just "Int,Double", postprocessor = "ppExcel", functionSet = PGExcel, language = LExcel} +#else +procFlag st (Default ms) = error "The --default option is not available. Please rebuild with GHC >= 7.6." +procFlag st Excel = st{postprocessor = "ppExcel", functionSet = PGExcel, language = LExcel} +#endif +procFlag st HTML = st{format = ForceHTML} +procFlag st PlainText = st{format = ForcePlain} +procFlag st NoTraining = st{sequentialTraining = Nothing, parallelTraining = Nothing} +procFlag st (SequentialTraining fp) = st{sequentialTraining = Just fp} +procFlag st (ParallelTraining fp) = st{parallelTraining = Just fp} +procFlag st (PostProcessor pp) = st{postprocessor = pp} + +versionString = "MagicHaskeller/MagicExceller backend server version " ++ versionInfo + +main :: IO () +main = do + (flags,args) <- readOpts + let stat = procFlags flags + hPutStrLn stderr versionString + qhandle <- openFile queryOut AppendMode + beginCT <- getClockTime + hPutStrLn stderr ("started at " ++ show beginCT) + + pgf <- case (functionSet stat, memoSize stat) of + (PGFull, Nothing) -> liftIO mkPgFull + (PGFull, Just sz) -> return $ pgfulls !! sz + (PGWithDoubleRatio, Nothing) -> return $ pgWithDoubleRatio + (PGWithDoubleRatio, Just sz) -> return $ pgWithDoubleRatios !! sz + (PGWithRatio, Nothing) -> return $ pgWithRatio + (PGWithRatio, Just sz) -> return $ pgWithRatios !! sz + (PGRatio, Nothing) -> return $ pgRatio + (PGRatio, Just sz) -> return $ pgRatios !! sz + (PGWithDouble, Nothing) -> liftIO mkPgWithDouble + (PGWithDouble, Just sz) -> return $ pgWithDoubles !! sz + (PGExcel, Nothing) -> liftIO mkPgExcel + (PGExcel, Just sz) -> liftIO $ mkPgExcels sz + + hscEnv <- prepareGHCAPI ["MagicHaskeller.Minimal","MagicHaskeller.FastRatio"] -- (Fast)Ratio must be here if Ratio is referred by the default declaration. +#if __GLASGOW_HASKELL__ >= 706 + hscEnv <- case defaultTypes stat of Nothing -> return hscEnv + Just def -> declareDefaults hscEnv def +#endif + case (parallelTraining stat, sequentialTraining stat) of + (Just fp, Just fs) -> do -- In this case, we make sure sequantial training starts after all the parallel training processes have finished. (The sequential training will be done for testing and benchmarking purposes.) + trainPara stat pgf hscEnv fp + trainSeq qhandle stat pgf hscEnv fs + (Just fp, Nothing) -> do -- In this case, every synthesis should be done in parallel. The service is started while training, but we prefer to be notified when all the training processes finish. + forkIO $ trainPara stat pgf hscEnv fp + return () + (Nothing, Just fs) -> trainSeq qhandle stat pgf hscEnv fs + (Nothing, Nothing) -> return () + hSetBuffering qhandle LineBuffering + case howToServe stat of + Network pid -> + withSocketsDo $ do +#ifdef UNIX + installHandler sigPIPE Ignore Nothing -- as suggested by /usr/share/doc/libghc6-network-doc/html/Network.html +#endif + socket <- listenOn pid + loop qhandle stat pgf hscEnv socket + STDIO -> interactive qhandle stat pgf hscEnv + PS -> do pgn <- getProgName + system $ "ps u -C "++pgn + return () -- stopGlobalPool + NoService -> return () -- stopGlobalPool + +#if __GLASGOW_HASKELL__ >= 706 +declareDefaults hscEnv str + = runGhc (Just libdir) $ do + setSession hscEnv + tupTy <- exprType $ "undefined :: (" ++ str ++ ")" + case splitTyConApp_maybe tupTy of + Nothing -> error $ str ++ " : invalid default type sequence" + Just (_tuptc, defaultTypes) -> setSession hscEnv{hsc_IC = (hsc_IC hscEnv){ic_default = Just defaultTypes}} >> getSession + +#endif + +waitUntil0 :: MVar Int -> IO Int +waitUntil0 mv = do i <- readMVar mv + yield + if (i>0) then waitUntil0 mv else return i + +loop qh so pgf hscEnv socket = do + (handle, hostname, _portnum) <- accept socket + hPutStr stderr $ "Connection from " ++ hostname ++ ".\n" + tid <- forkIO $ do hSetBuffering handle LineBuffering + answerHIO qh so pgf hscEnv handle handle + hPutStrLn stderr "closing" + hClose handle + loop qh so pgf hscEnv socket + +{- pgfの計算を入れんといかん． +-- same as main, with option `--interactive --no-training' +mainstd = do hscEnv <- prepareGHCAPI ["MagicHaskeller.Minimal"] + qhandle <- openFile queryOut AppendMode + hSetBuffering qhandle LineBuffering + interactive qhandle defaultSO pgf hscEnv +-} + +interactive qh so pgf hscEnv = sequence_ $ repeat $ hPutStrLn stderr "\\f -> ?" >> answerHIO qh so pgf hscEnv stdin stdout + +trainSeq qh d pgf hscEnv fp = do + r <- try $ openFile fp ReadMode + case r :: Either IOException Handle of + Left e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained sequentially beforehand.") + Right h -> do time $ do + processTrainers qh (preferPlain d) pgf hscEnv h + hPutStrLn stderr "In total," + return () + hPutStrLn stderr "performing GC..." + performGC + hPutStrLn stderr "done.\a" +#if __GLASGOW_HASKELL__ >= 706 + gcStatsAvailable <- getGCStatsEnabled + when gcStatsAvailable $ getGCStats >>= print +#endif +processTrainers qh so pgf hscEnv h = do + (r,t) <- time $ try (answerHIO qh so pgf hscEnv h stdout) + case r of Left e | isEOFError e -> do hClose h + return t + | otherwise -> error ("While training:\n" ++ show e) + Right () -> fmap (+t) $ processTrainers qh so pgf hscEnv h + +trainPara so pgf hscEnv fp = do + r <- try $ readFile fp + case r :: Either IOException String of + Left e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained in parallel beforehand.") + Right cs -> do beginCT <- getClockTime + runParIO $ trainParaPar (preferPlain so) pgf hscEnv $ lines cs +-- trainParaIO (preferPlain so) pgf hscEnv $ lines cs + endParaCT <- getClockTime + hPutStrLn stderr "All the training processes have finished." + hPutStrLn stderr $ showZero (timeDiffToString $ diffClockTimes endParaCT beginCT) ++ " have passed since the training started." +trainParaIO so pgf hscEnv css = do + numUnfinished <- newMVar (length css) + mapM_ (processTrainerPara (preferPlain so) pgf hscEnv numUnfinished) css + waitUntil0 numUnfinished +processTrainerPara so pgf hscEnv numUnfinished line = do + mid <- myThreadId + forkIO $ ((answerSIO so pgf hscEnv line >>= \(_,k) -> k `seq` modifyMVar_ numUnfinished (return . pred)) + `Control.Exception.catch` \exception -> throwTo mid (exception::SomeException) + ) + return () +preferPlain so = case format so of DefaultFormat -> so{format=ForcePlain} + _ -> so + +trainParaPar :: ServerOptions -> ProgGenSF -> HscEnv -> [String] -> ParIO () +trainParaPar so pgf hscEnv css = do ivks <- mapM (\line -> spawn $ liftIO $ fmap snd $ answerSIO so pgf hscEnv line) css + ks <- mapM get ivks + sum ks `seq` return () + +filterCompile :: GhcMonad m => String -> String -> m (ProgGenSF -> Bool -> [[Exp]]) +filterCompile postprocessor predStr = fmap unsafeCoerce (compileExpr ("f1EF " ++ postprocessor ++ " (\\f -> "++predStr++")")) -- :: m GHC.HValue) + +-- InteractiveEval.exprTypeで明示的に型推論するってことは，IntegerでなくIntでdefaultしたりしやすいってことか．めんどくさければとりあえずはエラーにしてmonomorphicなのを要求してもよい． + +-- package ghcのType.Typeもそんなにややこしい型じゃないし，exprTypeから変換するのが確実でいいか． +-- exprTypeやってcompileExprするのは二度手間ではあるが． + + +-- てゆーか，もしpackage MagicHaskellerを毎回読み込まなければならないとすればそっちの方がtime consuming. + +filterCompileIO :: GhcMonad m => String -> String -> m (ProgGenSF -> Bool -> IO [[Exp]]) +filterCompileIO postprocessor predStr = fmap unsafeCoerce (compileExpr ("MagicHaskeller.Minimal.f1EFIO " ++ postprocessor ++ " (\\f -> (("++predStr++") :: Bool))")) + +{- 使わんかも． +ghcTypeToType :: TyConLib -> GHC.Type -> MagicHaskeller.Types.Type +ghcTypeToType _ (TyVarTy var) = strToVarType $ show var +ghcTypeToType tcl (AppTy t0 t1) = ghcTypeToType tcl t0 `TA` ghcTypeToType tcl t1 +ghcTypeToType tcl (TyConApp tc ts) = let nstr = showSDoc (pprParenSymName tc) + tc' = case Data.Map.lookup nstr (fst tcl) of + Nothing -> TC $ (-1 - bakaHash nstr) -- error "nameToTyCon: unknown TyCon" + Just c -> TC c + in foldl TA tc' $ map (thcTypeToType tcl) ts +ghcTypeToType tcl (FunTy t0 t1) = ghcTypeToType tcl t0 :-> ghcTypeToType tcl t1 +ghcTypeToType tcl (ForAllTy v ty) = panic "Please make it monomorphic by giving a type signature." +-} + + +-- stdinとstdoutで動作確認できるように，inとoutを分ける． +answerHIO :: Handle -> ServerOptions -> ProgGenSF -> HscEnv -> Handle -> Handle -> IO () +answerHIO qhandle so pgf hscEnv ihandle ohandle = do + inp <- hGetLine ihandle -- hGetContents ihandleだと，最後に改行文字を入れちゃった時面倒．あと，hGetContentsの方がだいぶ遅いみたい． + case lex inp of [(":",rest)] -> if filter (not . isSpace) rest == "version" then hPutStrLn ohandle versionString else hPutStrLn ohandle $ inp ++ " : command unknown" + _ -> do + let (so', pred) = case reads inp of [(qo, pred)] -> (so{queryOptions=qo}, pred) + [] -> (so, inp) + putStrLn ("the predicate is "++pred) + hPutStrLn qhandle pred + (out,_) <- answerSIO so' pgf hscEnv pred + hPutStrLn ohandle out + +answerSIO :: ServerOptions -> ProgGenSF -> HscEnv -> String -> IO (String, Int) +answerSIO so pgf hscEnv pred = do + cmpd <- runGhc (Just libdir) $ setSession hscEnv >> compileOrFail (postprocessor so) pred + case cmpd of Left (funIO, sig) -> do + let e2s = case howToServe so of + STDIO | not $ format so == ForceHTML -> expToPlainString + _ | format so == ForcePlain -> expToPlainString + | otherwise -> expSigToString (language so) pred sig + result <- funIO pgf $ absents $ queryOptions so + let ess = take (depth $ queryOptions so) result + +-- let ess = take (depth $ queryOptions so) $ fun pgf $ absents $ queryOptions so + + return (unlines $ map (concat . map e2s) ess, length $ last ess) + Right errstr -> return ('!' : encodeBR (stringToHtmlString errstr), length errstr) -- 本当はこれもhowToServeにあわせるべき + +compileOrFail :: String -> String -> Ghc (Either (ProgGenSF -> Bool -> IO [[Exp]], String) String) +compileOrFail postproc predStr = handleSourceError (return . Right . show) $ do + funIO <- filterCompileIO postproc predStr +#if __GLASGOW_HASKELL__ >= 706 + -- In this case, the type obtained by exprType is polymorphic, so there is no point in adding the type signature. + let sig = "" +#else + ty <- exprType $ "\\f->("++predStr++")`asTypeOf`True" -- `asTypeOf` True をいれないと、 predStr = "f True True" のときにserverがpanic!になる。 + let sig = " :: " ++ removeQuantification (map crlfToSpace $ showPpr $ extractArgTy ty) +#endif + return $ Left (funIO, sig) + +-- assumes rank-1 types +extractArgTy ty = case splitForAllTys ty of (tvs, fty) -> case splitFunTys fty of (args, _bool) -> mkForAllTys tvs $ mkFunTys (Prelude.init args) $ last args + +crlfToSpace '\n' = ' ' +crlfToSpace c = c + +-- エラーコード中にもし\nがあった場合，
で置き換え．なぜかstringToHtmlStringはやってくれない． +encodeBR = concat . map (++"
") . lines + + + +-- exprType quantifies each Primitive type with `GHC.Types.' and `GHC.Bool., but mueval does not like this kind of quantification. +-- There exist quicker algorithms, but anyway the time for quantification removal should be ignorable. +removeQuantification "" = "" +removeQuantification xs@(y:ys) = case span (/='.') xs of (tk,'.':dr) | all isAlphaNum tk -> removeQuantification dr + | otherwise -> reverse (dropWhile isAlphaNum $ reverse tk) ++ removeQuantification dr + (tk,"") -> tk + +prepareGHCAPI :: [FilePath] -> IO HscEnv +prepareGHCAPI allfss = runGhc (Just libdir) $ do + dfs <- getSessionDynFlags +#if __GLASGOW_HASKELL__ >= 700 + let newf = xopt_set dfs{packageFlags = [ ExposePackage "MagicHaskeller" ]} Opt_ExtendedDefaultRules +#else + let newf = dfs{packageFlags = [ ExposePackage "MagicHaskeller" ]} +#endif + setSessionDynFlags newf -- result abandoned + +#if __GLASGOW_HASKELL__ >= 700 + modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":allfss) +#else + modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":allfss) +#endif +#if __GLASGOW_HASKELL__ >= 700 + setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName){GHC.ideclQualified = False} | moduleName <- "Prelude":allfss ] -- GHC 7.4 +#else + setContext [] modules +#endif + getSession diff --git a/MagicHaskeller/T10.hs b/MagicHaskeller/T10.hs --- a/MagicHaskeller/T10.hs +++ b/MagicHaskeller/T10.hs @@ -7,6 +7,7 @@ -- import PriorSubsts import Data.List(partition, sortBy) import Data.Monoid +import Data.Functor((<$>)) -- import MagicHaskeller.Types @@ -26,16 +27,28 @@ mergesortWithByBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [k] -> [k] mergesortWithByBot op cmp = mergesortWithByBot' op cmp . map return +mergesortWithByBotIO :: (k->k->k) -> (k -> k -> IO (Maybe Ordering)) -> [k] -> IO [k] +mergesortWithByBotIO op cmp = mergesortWithByBot'IO op cmp . map (:[]) + mergesortWithByBot' :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [[k]] -> [k] mergesortWithByBot' op cmp [] = [] mergesortWithByBot' op cmp [xs] = xs mergesortWithByBot' op cmp xss = mergesortWithByBot' op cmp (merge_pairsBot op cmp xss) +mergesortWithByBot'IO :: (k->k->k) -> (k -> k -> IO (Maybe Ordering)) -> [[k]] -> IO [k] +mergesortWithByBot'IO op cmp [] = return [] +mergesortWithByBot'IO op cmp [xs] = return xs +mergesortWithByBot'IO op cmp xss = mergesortWithByBot'IO op cmp =<< (merge_pairsBotIO op cmp xss) + merge_pairsBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [[k]] -> [[k]] merge_pairsBot op cmp [] = [] merge_pairsBot op cmp [xs] = [xs] merge_pairsBot op cmp (xs:ys:xss) = mergeWithByBot op cmp xs ys : merge_pairsBot op cmp xss +merge_pairsBotIO :: (k->k->k) -> (k -> k -> IO (Maybe Ordering)) -> [[k]] -> IO [[k]] +merge_pairsBotIO op cmp [] = return [] +merge_pairsBotIO op cmp [xs] = return [xs] +merge_pairsBotIO op cmp (xs:ys:xss) = liftM2 (:) (mergeWithByBotIO op cmp xs ys) $ merge_pairsBotIO op cmp xss mergeWithBy :: (k->k->k) -> (k->k->Ordering) -> [k] -> [k] -> [k] mergeWithBy op cmp = mergeWithByBot op (\x y -> Just (cmp x y)) @@ -51,6 +64,34 @@ Just LT -> x : mergeWithByBot op cmp xs (y:ys) Nothing -> mergeWithByBot op cmp xs ys -- Actually it is questionable if we may remove both of the expressions compared just because comparison between them fails, because only one of them might be responsible. + +-- cmp returns Nothing when the comparison causes time-out. +mergeWithByBotIO :: (k->k->k) -> (k -> k -> IO (Maybe Ordering)) -> [k] -> [k] -> IO [k] +mergeWithByBotIO op cmp xs [] = return xs +mergeWithByBotIO op cmp [] ys = return ys +mergeWithByBotIO op cmp (x:xs) (y:ys) + = do mbo <- x `cmp` y + case mbo of + Just GT -> (y :) <$> mergeWithByBotIO op cmp (x:xs) ys + Just EQ -> (x `op` y :) <$> mergeWithByBotIO op cmp xs ys + Just LT -> (x :) <$> mergeWithByBotIO op cmp xs (y:ys) + Nothing -> mergeWithByBotIO op cmp xs ys +-- Actually it is questionable if we may remove both of the expressions compared just because comparison between them fails, because only one of them might be responsible. + +diffSortedBy _ [] _ = [] +diffSortedBy _ vs [] = vs +diffSortedBy op vs@(c:cs) ws@(d:ds) = case op c d of EQ -> diffSortedBy op cs ds + LT -> c : diffSortedBy op cs ws + GT -> diffSortedBy op vs ds +diffSortedByBot _ [] _ = [] +diffSortedByBot _ vs [] = vs +diffSortedByBot op vs@(c:cs) ws@(d:ds) = case op c d of + Just EQ -> diffSortedByBot op cs ds + Just LT -> c : diffSortedByBot op cs ws + Just GT -> diffSortedByBot op vs ds +-- Nothing -> c : diffSortedByBot op cs ds -- I just do not know what is the best solution here, but when timeout happens, I temporarily believe @c@, and skip d. + Nothing -> diffSortedByBot op cs ds -- The above turned out to be not a good solution, because when an error (or a timeout) happens, the expression repeatedly appears at each depth. See newnotes on Dec. 18, 2011 + -- filters only emptySubst tokoro10nil :: Eq k => [([a],[k],i)] -> [([a],[k],i)] diff --git a/MagicHaskeller/TimeOut.hs b/MagicHaskeller/TimeOut.hs --- a/MagicHaskeller/TimeOut.hs +++ b/MagicHaskeller/TimeOut.hs @@ -1,24 +1,27 @@ -- -- (c) Susumu Katayama -- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} module MagicHaskeller.TimeOut where import Control.Concurrent(forkIO, killThread, myThreadId, ThreadId, threadDelay, yield) -import Control.Concurrent.SampleVar +import Control.Concurrent.MVar import Control.Exception -- (catch, Exception(..)) -- import System.Posix.Unistd(getSysVar, SysVar(..)) -- import System.Posix.Process(getProcessTimes, ProcessTimes(..)) -- import System.Posix.Types(ClockTick) import System.CPUTime import System.IO.Unsafe(unsafePerformIO) +#if __GLASGOW_HASKELL__ >=702 +import System.IO.Unsafe(unsafeDupablePerformIO) +#endif import Control.Monad(when) import System.IO import Debug.Trace -- This IS necessary to monitor errors in the subprocs. --- import System.Timeout +import qualified System.Timeout import MagicHaskeller.Options(Opt(..)) #ifdef FORCIBLETO @@ -37,9 +40,13 @@ #endif unsafeWithPTO :: Maybe Int -> a -> Maybe a --- x #ifdef CHTO +#if 0 +-- x #if __GLASGOW_HASKELL__ >= 702 +unsafeWithPTO pto a = unsafeDupablePerformIO $ wrapExecution ( +#else unsafeWithPTO pto a = unsafePerformIO $ wrapExecution ( - maybeWithTO seq pto (return a) +#endif + maybeWithTO seq pto (return $! a) ) maybeWithTO :: (a -> IO () -> IO ()) -- ^ seq or deepSeq(=Control.Parallel.Strategies.sforce). For our purposes seq is enough, because @a@ is either 'Bool' or 'Ordering'. -> Maybe Int -> IO a -> IO (Maybe a) @@ -57,8 +64,8 @@ unsafeOpWithPTO :: Maybe Int -> (a->b->c) -> a -> b -> Maybe c unsafeOpWithPTO mto op l r = unsafeWithPTO mto (op l r) --- ¥½¡¼¥¹¤ò¤ß¤¿´¶¤¸¡¤MVar¤äSampleVar¤òºî¤ëoverhead¤Ï̵»ë¤Ç¤­¤½¤¦¡¥ --- data CHTO a = CHTO {timeInMicroSecs :: Int, sv :: SampleVar (Maybe a)} +-- ¥½¡¼¥¹¤ò¤ß¤¿´¶¤¸¡¤MVar¤äMSampleVar¤òºî¤ëoverhead¤Ï̵»ë¤Ç¤­¤½¤¦¡¥ +-- data CHTO a = CHTO {timeInMicroSecs :: Int, sv :: MSampleVar (Maybe a)} {- unsafeEvaluate :: Int -> a -> Maybe a @@ -68,9 +75,21 @@ maybeWithTO' :: (a -> IO () -> IO ()) -> Maybe Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a) maybeWithTO' _ Nothing action = do a <- action id return (Just a) -maybeWithTO' dsq (Just t) action = withTO' dsq t action ---maybeWithTO' dsq (Just t) action = timeout t (action undefined) -- System.Timeout.timeout¤ò»È¤¦¤È®¤¯¤Ê¤ë¡¥ +--maybeWithTO' dsq (Just t) action = withTO' dsq t action -- ¸Å¤¤¤ä¤Ä +{- +maybeWithTO' dsq (Just t) action = System.Timeout.timeout t (action undefined) -- System.Timeout.timeout¤ò»È¤¦¤È®¤¯¤Ê¤ë¡¥ + `catch` \(e :: SomeException) -> -- trace ("within maybeWithTO': " ++ show e) $ + return Nothing +-} +maybeWithTO' dsq (Just t) action = do tid <- myThreadId + bracket (forkIO (threadDelay t >> -- hPutStrLn stderr "throwing Timeout" >> + throwTo tid (ErrorCall "Timeout"))) + (\th -> {- block $ -} killThread th) + (\_ -> fmap Just $ action (yield>>)) + `Control.Exception.catch` \(e :: SomeException) -> -- trace ("within maybeWithTO': " ++ show e) $ + return Nothing + -- 'withTO' creates CHTO every time it is called. Currently unused. -- withTO :: DeepSeq a => Int -> IO a -> IO (Maybe a) -- withTO timeInMicroSecs action = withTO' deepSeq timeInMicroSecs (const action) @@ -78,19 +97,24 @@ withTO' dsq timeInMicroSecs action = do -- clk_tck <- getSysVar ClockTick -- let ticks = fromInteger (clk_tck * toInteger timeInMicroSecs `div` 1000000) - resSV <- newEmptySampleVar + resMV <- newEmptyMVar do - forkIO (catchIt resSV (do + (catchIt resMV (do tid <- myThreadId chtid <- forkIO (do threadDelay timeInMicroSecs -- wait deadline -- this line makes sure that timeInMicroSecs has really passed in the process time, but I guess this has no sense, because userTime is shared among Concurrent Haskell threads. - writeSampleVar resSV Nothing + hPutStrLn stderr "writing Nothing" + putMVar resMV Nothing + hPutStrLn stderr "killing the main" killThread tid) - -- res <- action (catchYield tid resSV) + -- res <- action (catchYield tid resMV) res <- action (yield>>) - res `dsq` writeSampleVar resSV (Just res) + hPutStrLn stderr "writing Just" + res `dsq` putMVar resMV (Just res) + hPutStrLn stderr "killing the thread for timeout" killThread chtid)) - readSampleVar resSV + hPutStrLn stderr "reading MV" + readMVar resMV wrapExecution = id --wrapExecution = measureExecutionTime @@ -103,8 +127,8 @@ return res -- Catch exceptions such as stack space overflow -catchIt :: (SampleVar (Maybe a)) -> IO () -> IO () -#ifdef SHOWEXCEPTIONS +catchIt :: (MVar (Maybe a)) -> IO () -> IO () +#ifdef REALDYNAMIC catchIt sv act = act -- disable #else catchIt sv act = Control.Exception.catch act (handler sv) @@ -114,15 +138,15 @@ -- realHandler sv (AsyncException ThreadKilled) = return () -- If the thread is killed by ^C (i.e. not by another thread), sv is left empty. So, the parent thread can catch ^C while waiting. {- #ifdef REALDYNAMIC --- realHandler sv err = trace (show err) $ writeSampleVar sv Nothing -realHandler sv (ErrorCall str) = trace str $ writeSampleVar sv Nothing +-- realHandler sv err = trace (show err) $ putMVar sv Nothing +realHandler sv (ErrorCall str) = trace str $ putMVar sv Nothing #endif -} -realHandler sv err = writeSampleVar sv Nothing +realHandler sv err = putMVar sv Nothing catchYield tid sv action = Control.Exception.catch (yield >> action) (childHandler tid sv) childHandler tid sv err = Control.Exception.catch (realChildHandler tid sv (err::SomeException)) (childHandler tid sv) -realChildHandler tid sv err = do writeSampleVar sv Nothing +realChildHandler tid sv err = do putMVar sv Nothing killThread tid error "This thread must have been killed...." {- diff --git a/MagicHaskeller/TyConLib.hs b/MagicHaskeller/TyConLib.hs --- a/MagicHaskeller/TyConLib.hs +++ b/MagicHaskeller/TyConLib.hs @@ -34,7 +34,7 @@ defaultTyCons i | i<=7 = tuplename i -} defaultTyCons :: [(Kind, TypeName)] -defaultTyCons = [(0, "()"), (1, "[]")] ++ [ (i, tuplename i) | i<-[2..tupleMax] ] ++ [(0, "Int"), (0, "Char"), (0, "Bool"), (0, "Integer"), (0, "Double"), (0, "Float"), (1,"Maybe"), (1,"IO"), (2,"Either"), (0,"Ordering"), (1,"Gen")] +defaultTyCons = [(0, "()"), (1, "[]")] ++ [ (i, tuplename i) | i<-[2..tupleMax] ] ++ [(0, "Int"), (0, "Char"), (0, "Bool"), (0, "Integer"), (0, "Double"), (0, "Float"), (1,"Maybe"), (1,"IO"), (2,"Either"), (0,"Ordering"), (1,"Ratio"), (1,"Gen")] tupleMax = 7 {- can be used at least with lthprof defaultTyCons = [] diff --git a/MagicHaskeller/Types.lhs b/MagicHaskeller/Types.lhs --- a/MagicHaskeller/Types.lhs +++ b/MagicHaskeller/Types.lhs @@ -6,10 +6,10 @@ {-# OPTIONS -cpp -funbox-strict-fields #-} -module MagicHaskeller.Types(Type(..), Kind, TyCon, TyVar, TypeName, Class(..), Typed(..), tyvars, Subst, plusSubst, +module MagicHaskeller.Types(Type(..), Kind, TyCon, TyVar, TypeName, Typed(..), tyvars, Subst, plusSubst, emptySubst, apply, mgu, varBind, match, maxVarID, normalizeVarIDs, normalize, Decoder(..), typer, typee, negateTVIDs, limitType, saferQuantify, quantify, quantify', unquantify, lookupSubst, unifyFunAp, - alltyvars, mapTV, size, unitSubst, applyCheck, assertsubst, substOK, eqType, getRet, getArity, splitArgs, getArgs, pushArgs, popArgs, mguFunAp, strToVarType, revSplitArgs, revGetArgs, splitArgsCPS, bakaHash + alltyvars, mapTV, size, unitSubst, applyCheck, assertsubst, substOK, eqType, getRet, getArity, getLongerArity, splitArgs, getArgs, pushArgs, popArgs, mguFunAp, revSplitArgs, revGetArgs, splitArgsCPS, module Data.Int ) where import Data.List import Control.Monad @@ -18,6 +18,7 @@ import Test.QuickCheck -- this is since 6.4 -- import Debug.QuickCheck #endif +import Data.Int -- import Debug.Trace @@ -32,7 +33,7 @@ -- :> is same as :-> except FMType.lhs assumes it is a type constructor. -data Type = TV !TyVar | TC !TyVar | TA Type Type | Type :> Type | Type :-> Type +data Type = TV {-# UNPACK #-} !TyVar | TC {-# UNPACK #-} !TyVar | TA Type Type | Type :> Type | Type :-> Type | Type :=> Type deriving (Eq, Ord, Read) size :: Type -> Int @@ -71,6 +72,7 @@ mapTV f t = -- if t/=t then undefined else mtv t where mtv (TA t0 t1) = TA (mtv t0) (mtv t1) + mtv (t1 :=> t0) = (mtv t1) :=> (mtv t0) mtv (t1 :-> t0) = (mtv t1) :-> (mtv t0) mtv (t1 :> t0) = (mtv t1) :> (mtv t0) mtv (TV tv) = TV (f tv) @@ -98,6 +100,7 @@ alltyvars' (TA t u) s = alltyvars' t s . alltyvars' u s alltyvars' (u :> t) s = alltyvars' t s . alltyvars' u s alltyvars' (u :-> t) s = alltyvars' t s . alltyvars' u s +alltyvars' (u :=> t) s = alltyvars' t s -- Is this enough? -- These can sometimes be VERY time-consuming, because they are used by mgu, varBind, etc. {-# INLINE tyvars #-} @@ -110,6 +113,7 @@ tyvars' (TA t u) = tyvars' t . tyvars' u tyvars' (u :> t) = tyvars' t . tyvars' u tyvars' (u :-> t) = tyvars' t . tyvars' u +tyvars' (u :=> t) = tyvars' t -- use this instead of QType maxVarID :: Type -> TyVar @@ -118,6 +122,7 @@ maxVarID (TA t u) = maxVarID t `max` maxVarID u maxVarID (t :> u) = maxVarID t `max` maxVarID u maxVarID (t :-> u) = maxVarID t `max` maxVarID u +maxVarID (_ :=> u) = maxVarID u {- higher-order kind$B$O9M$($J$$$H$$$&$+!$(B(*->*)->*$B$H(B*->*$B$r6hJL$7$J$$!J7?0z?t$N?t$N$_9MN8$9$k!K!%$=$N>e$G!$(Btype Kind = Int$B$H$9$k!%(BMemo$B$9$k$H$-$K(BKind$B$G(Bindex$B$7$?$$$C$F$N$H!$7?0z?t$N(BKind$B$O?dO@$G$-$J$$$N$G!%(B $B$d$C$Q@53N$K$O!$!V(B(*->*)->*$B$H(B*->*$B$r6hJL$7$J$$!W$G$O$J$/!$!V(B(*->*)->* (higher order kind)$B$rG'$a$J$$!W$H$$$&$Y$-!%(B @@ -135,31 +140,26 @@ -- comparison between cs and ds is done in TypeLib, comparing types of different vars. -type TyVar = Int -type TyCon = Int +type TyVar = Int8 +type TyCon = Int8 type TypeName = String -data Class = Cl Int TypeName [Type] deriving (Show, Ord, Eq, Read) - -mapCls :: (Type -> Type) -> [Class] -> [Class] -mapCls f cs = [ Cl i n (map f ts) | Cl i n ts <- cs ] - -- Encoder and Decoder are partly moved to FMType.lhs -- TyVar should be shared, so it is returned by the decoder. -- $B$"$H!"(BdecoList$B$O$R$@$j$+$i$_$.$K$N$S$F$$$C$?$[$&$,$$$$$N$+!)(B -data Decoder = Dec [TyVar] Int +data Decoder = Dec [TyVar] TyVar deriving Show {-# INLINE normalizeVarIDs #-} -- FMType$B!$(BMemoTree$B$J$I$G(Bindex$B$9$k$H$-$N$?$a$K!$(BvarID$B$r(B0,1,...$B$K(Broot$BB&$+$i=g$K@55,2=$9$k(B -normalizeVarIDs :: Type -> Int -> (Type, Decoder) +normalizeVarIDs :: Type -> TyVar -> (Type, Decoder) normalizeVarIDs ty mx = let decoList = sieve $ tyvars ty tup = zip decoList [0..] encoType = mapTV (\tv -> case lookup tv tup of Just n -> n) ty - len = length decoList + len = genericLength decoList margin = -- trace ("normalizeVarIDs: mx == "++show mx++ " and len = " ++ show len) $ mx + 1 - len in -- trace ("len = " ++ show len) $ $B$[$H$s$I$N%1!<%9$G(B0$B$+(B1$B!$$?$^!<$K(B2$B$+(B3 @@ -179,6 +179,7 @@ negUnquantify (TA t u) = TA (negUnquantify t) (negUnquantify u) negUnquantify (u :-> t) = negUnquantify u :-> negUnquantify t negUnquantify (u :> t) = negUnquantify u :> negUnquantify t +negUnquantify (u :=> t) = error "negUnquantify: applied to types with contexts" negUnquantify t = t quantify ty = quantify' (normalize ty) @@ -193,6 +194,7 @@ unquantify (TA t u) = TA (unquantify t) (unquantify u) unquantify (u :-> t) = unquantify u :-> unquantify t unquantify (u :> t) = unquantify u :> unquantify t +unquantify (u :=> t) = error "unquantify: applied to types with contexts" unquantify t = t {- @@ -207,6 +209,7 @@ uniFunAp :: MonadPlus m => Type -> Type -> m Type uniFunAp (a:->r) t = do subst <- mgu (getRet a) (getRet t) return (apply subst r) +uniFunAp (a:=>r) t = uniFunAp (a:->r) t uniFunAp f t = mzero -- error ("uniFunAp: f = "++show f++" and t = "++show t) @@ -218,16 +221,18 @@ let retv = (apply subst r) trace ("retv = "++show retv) $ return retv mfa (a:>r) t = mfa (a:->r) t -- mguFunAp is only used by PolyDynamic +mfa (a:=>r) t = mfa (a:->r) t -- mguFunAp is only used by PolyDynamic mfa t@(TV _) _ = return t -- mguFunAp assumes different name spaces mfa f t = mzero -pushArgsCPS :: (Int -> [Type] -> Type -> a) -> [Type] -> Type -> a +pushArgsCPS :: Integral i => (i -> [Type] -> Type -> a) -> [Type] -> Type -> a pushArgsCPS f = pa 0 where pa n args (t0:->t1) = pa (n+1) (t0:args) t1 - pa n args (t0:>t1) = pa (n+1) (t0:args) t1 + pa n args (t0:>t1) = pa (n+1) (t0:args) t1 + pa n args (t0:=>t1) = pa (n+1) (t0:args) t1 pa n args retty = f n args retty pushArgs :: [Type] -> Type -> ([Type],Type) @@ -235,7 +240,12 @@ getRet = pushArgsCPS (\i a r -> r) [] getArgs = pushArgsCPS (\i a r -> a) [] -getArity = pushArgsCPS (\i _ _ -> i) undefined +getLongerArity :: Integral i => Type -> i +getLongerArity = pushArgsCPS (\i _ _ -> i) undefined +getArity (_:->t) = succ $ getArity t +getArity (_:>t) = succ $ getArity t +getArity (_:=>t) = getArity t -- So, the arity is not incremented in this case. +getArity _ = 0 splitArgsCPS :: (Int -> [Type] -> Type -> a) -> Type -> a splitArgsCPS f = pushArgsCPS f [] @@ -244,7 +254,7 @@ splitArgs = pushArgs [] -- $B5U=g$K@Q$s$G$$$/(B -revSplitArgs :: Type -> (Int,[Type],Type) +revSplitArgs :: Integral i => Type -> (i,[Type],Type) revSplitArgs (t0:->t1) = case revSplitArgs t1 of (n,args,ret) -> (n+1, t0:args, ret) revSplitArgs t = (0, [], t) @@ -280,7 +290,7 @@ \begin{code} -type Subst = [(Int,Type)] +type Subst = [(TyVar,Type)] showsAssoc [] = id showsAssoc ((k,v):assocs) = (' ':) . shows k . ("\t|-> "++) . shows v . ('\n':) . showsAssoc assocs @@ -327,6 +337,7 @@ return (s2 `plusSubst` s1) varBind :: MonadPlus m => TyVar -> Type -> m Subst +varBind _ (_:=>_) = mzero varBind u t | t == TV u = return emptySubst | u `elem` (tyvars t) = mzero | otherwise = return (unitSubst u t) @@ -343,6 +354,7 @@ where toString' k (TV i) = ('a':) . shows i -- can be used to synthesize a generically typed program. toString' k (TC i) = ('K':) . shows k . ('I':) . shows i toString' k (TA t0 t1) = showParen True (toString' (k+1) t0 . (' ':) . toString' 0 t1) -- mandatory, just in case. + toString' k (t0 :=> t1) = showParen True (toString' 0 t0 . ("=>"++) . toString' 0 t1) toString' k (t0 :-> t1) = showParen True (toString' 0 t0 . ("->"++) . toString' 0 t1) toString' k (t0 :> t1) = showParen True (("(->) "++) . toString' 0 t0 . (' ':) . toString' 0 t1) @@ -365,7 +377,7 @@ -- s1$B$r$d$C$?$"$H(Bs0$B$r(Bapply -- applyHoge s t = if isIllegalSubst s then error "Illegal in applyHoge" else apply s t -lookupSubst :: MonadPlus m => Subst -> Int -> m Type +lookupSubst :: MonadPlus m => Subst -> TyVar -> m Type lookupSubst subst i = case lookup i subst of Nothing -> mzero Just x -> return x @@ -378,6 +390,7 @@ apply' (TA t0 t1) = TA (apply' t0) (apply' t1) apply' (t0:->t1) = apply' t0 :-> apply' t1 apply' (t0:>t1) = apply' t0 :> apply' t1 + apply' (t0:=>t1) = apply' t0 :=> apply' t1 applyCheck subst t = -- trace ("t= " ++ show t ++ " and subst = "++ show subst) $ apply subst t @@ -385,13 +398,12 @@ -- moved from ReadType.lhs - +{- This used to be Ok, but now I want to use Int8 for TyVar. strToVarType str = TV (bakaHash str) -- This is Ok, because eventually normalizeVarIDs will be called. (But there can be Int overflow....) Also, when I coded normalizeVarIDs I assumed the tvIDs are small. +bakaHash :: String -> TyVar bakaHash [] = 0 -bakaHash (c:cs) = ord c + bakaHash cs * 131 - -undef = [] -- for now - +bakaHash (c:cs) = fromIntegral (ord c) + bakaHash cs * 131 +-} \end{code} diff --git a/MagicHaskeller/predicates b/MagicHaskeller/predicates new file mode 100644 --- /dev/null +++ b/MagicHaskeller/predicates @@ -0,0 +1,48 @@ +( f "abcdef" ( 3::Int ) ( 5::Int ) == "de" ) && f "U" ( - (1::Int)) ( - (1::Int)) == "U" +( f ( 4::Int ) [ ( 1::Int ) , ( 2::Int ) , ( 3::Int ) ] == ( 10::Int ) ) && f ( - (1::Int)) [ ] == - (1::Int) +(f "snbns" && not ( f "smns" ) ) && f "12345" == False +(f [ ( ( 3::Int ) + ) , ( * ( 8::Int ) ) ] [ ( 2::Int ) , ( 4::Int ) ] == [ ( 5::Int ) , ( 32::Int ) ] ) +(f [ ( + ( 3::Int ) ) , ( ( 4::Int ) - ) ] ( 5::Int ) == [ ( 8::Int ) , - ( 1::Int ) ] ) +const True ( f :: [ Char ] ) +f "56789" (0::Int)== '9' && f "5678910" (1::Int)== '1' +f "abbcccbbb" == "abc" +f "abbcccbbb" == [ "a" , "bb" , "ccc" , "bbb" ] +f "abcd" "efgh" == "aebfcgdh" +f "abcde" 'c' == (2::Int) +f "abcde" (2::Int)== "de" && f "abc" (1::Int)== "c" && f "1h" ( - (1::Int)) == "" +f "asddf" == (5::Int) +f "e" (2::Int)== "ee" && f "r" (3::Int)== "rrr" +f "ehog" "hog" && not ( f "hop" "hon" ) +f ',' [ "kore" , "wa" , "pen" ] == "kore,wa,pen" +f 'c' 'c' && not ( f 'g' 'h' ) +f ( ( * ) :: Int -> Int -> Int ) [ (2::Int), (4::Int), (5::Int)] == [ (4::Int), (16::Int), (25::Int)] +f ( (3::Int), (4::Int)) == (7::Int) +f ( * (3::Int)) [ (5::Int), (7::Int)] == [ (15::Int), (21::Int)] +f ( - (3::Int)) == Left (3::Int)&& f (4::Int)== Right (4::Int) +f ( 7::Int ) ( 7::Int ) && not ( f ( 7::Int ) ( 6::Int ) ) +f ( Left ( - (3::Int)) ) == (3::Int)&& f ( Right (4::Int)) == (4::Int) +f ( succ :: Int -> Int ) (1::Int)== (2::Int) +f (3::Int)"abcde" == 'd' +f (3::Int)(5::Int)== [ (3::Int), (4::Int), (5::Int)] +f (4::Int)== (24::Int)&& f (5::Int)== (25::Int) +f (4::Int)[ (1::Int), (2::Int), (3::Int)] == (10::Int) +f == [ (1::Int), (3::Int)] +f True True == True && f False False == True +f [ "ABCDE" , "DF" , "1234" , "" ] == [ "" , "DF" , "1234" , "ABCDE" ] +f [ ( 'a' , (1::Int)) , ( 'b' , (2::Int)) ] 'b' == Just (2::Int) +f [ ( (3::Int)* ) , ( (4::Int)+ ) ] (8::Int)== [ (24::Int), (12::Int)] +f [ ( (3::Int)+ ) , ( * (8::Int)) ] [ (2::Int), (4::Int)] == [ (5::Int), (32::Int)] +f [ ( 6::Int ) , ( 5::Int ) , ( 5::Int ) , ( 3::Int ) , ( 6::Int ) ] == [ ( 3::Int ) , ( 5::Int ) , ( 6::Int ) ] +f [ (1::Int), (2::Int), (1::Int), (1::Int)] ~= 0.2 +f [ (1::Int), (2::Int), (1::Int), (1::Int)] ~= [ 0.2 , 3.0 ] +f [ (1::Int), (2::Int), (2::Int), (3::Int), (3::Int), (3::Int), (2::Int), (2::Int), (2::Int)] == [ (1::Int), (2::Int), (3::Int)] +f [ (1::Int), (2::Int), (2::Int), (3::Int), (3::Int), (3::Int), (2::Int), (2::Int), (2::Int)] == [ [ (1::Int)] , [ (2::Int), (2::Int)] , [ (3::Int), (3::Int), (3::Int)] , [ (2::Int), (2::Int), (2::Int)] ] +f [ (1::Int).. (5::Int)] == (4::Int)&& f [ - (2::Int), - (3::Int)] == ( - (2::Int)) +f [ (3::Int), (4::Int)] [ (4::Int), (5::Int)] == [ (7::Int), (9::Int)] +f [ True ] [ True ] && not ( f [ True ] [ False ] ) +length ( f :: String ) == ( 1::Int ) +f [3, 4.5, 7.5] ~= 5.0 +f 3.54 ~= 3.5 +f [3,4,0.2] ~= [9,16,0.04] +f 3.7 ~= 4 +f [3, 4] [5, 6] ~= [3.5, 4.6] diff --git a/MagicHaskeller/predicatesAug2014 b/MagicHaskeller/predicatesAug2014 new file mode 100644 --- /dev/null +++ b/MagicHaskeller/predicatesAug2014 @@ -0,0 +1,79 @@ +( f "abcdef" ( 3::Int ) ( 5::Int ) == "de" ) && f "U" ( - (1::Int)) ( - (1::Int)) == "U" +( f ( 4::Int ) [ ( 1::Int ) , ( 2::Int ) , ( 3::Int ) ] == ( 10::Int ) ) && f ( - (1::Int)) [ ] == - (1::Int) +(f "snbns" && not ( f "smns" ) ) && f "12345" == False +(f [ ( ( 3::Int ) + ) , ( * ( 8::Int ) ) ] [ ( 2::Int ) , ( 4::Int ) ] == [ ( 5::Int ) , ( 32::Int ) ] ) +(f [ ( + ( 3::Int ) ) , ( ( 4::Int ) - ) ] ( 5::Int ) == [ ( 8::Int ) , - ( 1::Int ) ] ) +const True ( f :: [ Char ] ) +f "56789" (0::Int)== '9' && f "5678910" (1::Int)== '1' +f "abbcccbbb" == "abc" +f "abbcccbbb" == [ "a" , "bb" , "ccc" , "bbb" ] +f "abcd" "efgh" == "aebfcgdh" +f "abcde" 'c' == (2::Int) +f "abcde" (2::Int)== "de" && f "abc" (1::Int)== "c" && f "1h" ( - (1::Int)) == "" +f "asddf" == (5::Int) +f "e" (2::Int)== "ee" && f "r" (3::Int)== "rrr" +f "ehog" "hog" && not ( f "hop" "hon" ) +f ',' [ "kore" , "wa" , "pen" ] == "kore,wa,pen" +f 'c' 'c' && not ( f 'g' 'h' ) +f ( ( * ) :: Int -> Int -> Int ) [ (2::Int), (4::Int), (5::Int)] == [ (4::Int), (16::Int), (25::Int)] +f ( (3::Int), (4::Int)) == (7::Int) +f ( * (3::Int)) [ (5::Int), (7::Int)] == [ (15::Int), (21::Int)] +f ( - (3::Int)) == Left (3::Int)&& f (4::Int)== Right (4::Int) +f ( 7::Int ) ( 7::Int ) && not ( f ( 7::Int ) ( 6::Int ) ) +f ( Left ( - (3::Int)) ) == (3::Int)&& f ( Right (4::Int)) == (4::Int) +f ( succ :: Int -> Int ) (1::Int)== (2::Int) +f (3::Int)"abcde" == 'd' +f (3::Int)(5::Int)== [ (3::Int), (4::Int), (5::Int)] +f (4::Int)== (24::Int)&& f (5::Int)== (25::Int) +f (4::Int)[ (1::Int), (2::Int), (3::Int)] == (10::Int) +f == [ (1::Int), (3::Int)] +f True True == True && f False False == True +f [ "ABCDE" , "DF" , "1234" , "" ] == [ "" , "DF" , "1234" , "ABCDE" ] +f [ ( 'a' , (1::Int)) , ( 'b' , (2::Int)) ] 'b' == Just (2::Int) +f [ ( (3::Int)* ) , ( (4::Int)+ ) ] (8::Int)== [ (24::Int), (12::Int)] +f [ ( (3::Int)+ ) , ( * (8::Int)) ] [ (2::Int), (4::Int)] == [ (5::Int), (32::Int)] +f [ ( 6::Int ) , ( 5::Int ) , ( 5::Int ) , ( 3::Int ) , ( 6::Int ) ] == [ ( 3::Int ) , ( 5::Int ) , ( 6::Int ) ] +f [ (1::Int), (2::Int), (1::Int), (1::Int)] ~= 0.2 +f [ (1::Int), (2::Int), (1::Int), (1::Int)] ~= [ 0.2 , 3.0 ] +f [ (1::Int), (2::Int), (2::Int), (3::Int), (3::Int), (3::Int), (2::Int), (2::Int), (2::Int)] == [ (1::Int), (2::Int), (3::Int)] +f [ (1::Int), (2::Int), (2::Int), (3::Int), (3::Int), (3::Int), (2::Int), (2::Int), (2::Int)] == [ [ (1::Int)] , [ (2::Int), (2::Int)] , [ (3::Int), (3::Int), (3::Int)] , [ (2::Int), (2::Int), (2::Int)] ] +f [ (1::Int).. (5::Int)] == (4::Int)&& f [ - (2::Int), - (3::Int)] == ( - (2::Int)) +f [ (3::Int), (4::Int)] [ (4::Int), (5::Int)] == [ (7::Int), (9::Int)] +f [ True ] [ True ] && not ( f [ True ] [ False ] ) +length ( f :: String ) == ( 1::Int ) +f [3, 4.5, 7.5] ~= 5.0 +f 3.54 ~= 3.5 +f [3,4,0.2] ~= [9,16,0.04] +f 3.7 ~= 4 +f [3, 4] [5, 6] ~= [3.5, 4.6] +( f "abc" 'c' == 3 ) && f "Abc\nd Ef" 'b' == 2 +( f ( + 4 ) ( Just 6 ) == ( Just 10 ) ) && f id ( Just ( - 1 ) ) ~= Just ( - 1 ) +f "123" == 'a' +f 32 == ' ' +( ( ( ( ( f "kristoffer" "reffotsirk" == True ) && f "" "\nm Z" ~= False ) && f "\nm Z" "" ~= False ) && f "" " +" ~= True ) && f "\nm Z" "\nm Z" ~= False ) && f "" "12345" ~= False +f "ancd ed ad e ww" == [ 15 , 5 ] +f "a" == f "a" +f "lollolabacad" 2 ~= "ollbcd" +f ( + 4 ) ( Just ( Just 6 ) ) == Just ( Just 10 ) +f ( 1 , 'a' ) ~= ( 3 , 'c' ) +f 1 'a' ~= ( 2 , 'b' ) +f 'a' ~= 'b' +f ( Left 3 ) == 3 && f ( Right 4 ) == 4 +f 1 ( Just 1 ) ( Just ( Just 1 ) ) ( Just ( Just ( Just 1 ) ) ) ( Just ( Just ( Just ( Just 1 ) ) ) ) ( Just ( +Just ( Just ( Just ( Just 1 ) ) ) ) ) == 1 +f 1 [ 1 ] [ [ 1 ] ] [ [ [ 1 ] ] ] [ [ [ [ 1 ] ] ] ] [ [ [ [ [ 1 ] ] ] ] ] == 1 +f 1 ~= [ [ ] ] && f 2 ~= [ [ [ ] ] , [ ] ] +f 2 ( ) == 1 +f 2 [ 1 , 2 ] == [ [ 1 , 1 ] , [ 1 , 2 ] , [ 2 , 1 ] , [ 2 , 2 ] ] +f 3 == [ "a" , "b" , "c" ] +( f "abc" 'c' == 3 ) && f "Abc\nd Ef" 'b' == 2 +f 'a' == [ "a" , "b" , "c" ] +f 3 [ 1 , 2 , 4 , 7 ] == [ 1 , 2 , 3 , 4 , 7 ] +f [ "a" , "b" , "c" , "d" ] ~= "e" +f [ 0 , 1 , 2 , 3 , 4 , 5 , 6 , 7 ] == [ "000" , "001" , "011" , "010" , "110" , "111" , "101" , "100" ] +f [ 1 , 2 ] [ 3 , 4 ] ~= [ [ 1 , 3 ] , [ 1 , 4 ] , [ 2 , 3 ] , [ 2 , 4 ] ] +f [ Nothing , Nothing , Just "a" , Just "b" ] == "a" +f [ const 3 , head , ( sum . take 2 ) ] == [ 3 , 3 , 6 ] +f [ f [ 3 , 4 , 5 ] + 5 ] ~= 12.1 +fmap f [ 1 , 2 , 3 , 4 ] ~= [ sinh 1 , cosh 2 , sinh 3 , cosh 4 ] diff --git a/MagicHaskeller/predicatesServed b/MagicHaskeller/predicatesServed new file mode 100644 --- /dev/null +++ b/MagicHaskeller/predicatesServed @@ -0,0 +1,79 @@ +( f "abcdef" ( 3::Int ) ( 5::Int ) == "de" ) && f "U" ( - (1::Int)) ( - (1::Int)) == "U" +( f ( 4::Int ) [ ( 1::Int ) , ( 2::Int ) , ( 3::Int ) ] == ( 10::Int ) ) && f ( - (1::Int)) [ ] == - (1::Int) +(f "snbns" && not ( f "smns" ) ) && f "12345" == False +(f [ ( ( 3::Int ) + ) , ( * ( 8::Int ) ) ] [ ( 2::Int ) , ( 4::Int ) ] == [ ( 5::Int ) , ( 32::Int ) ] ) +(f [ ( + ( 3::Int ) ) , ( ( 4::Int ) - ) ] ( 5::Int ) == [ ( 8::Int ) , - ( 1::Int ) ] ) +const True ( f :: [ Char ] ) +f "56789" (0::Int)== '9' && f "5678910" (1::Int)== '1' +f "abbcccbbb" == "abc" +f "abbcccbbb" == [ "a" , "bb" , "ccc" , "bbb" ] +f "abcd" "efgh" == "aebfcgdh" +f "abcde" 'c' == (2::Int) +f "abcde" (2::Int)== "de" && f "abc" (1::Int)== "c" && f "1h" ( - (1::Int)) == "" +f "asddf" == (5::Int) +f "e" (2::Int)== "ee" && f "r" (3::Int)== "rrr" +f "ehog" "hog" && not ( f "hop" "hon" ) +f ',' [ "kore" , "wa" , "pen" ] == "kore,wa,pen" +f 'c' 'c' && not ( f 'g' 'h' ) +f ( ( * ) :: Int -> Int -> Int ) [ (2::Int), (4::Int), (5::Int)] == [ (4::Int), (16::Int), (25::Int)] +f ( (3::Int), (4::Int)) == (7::Int) +f ( * (3::Int)) [ (5::Int), (7::Int)] == [ (15::Int), (21::Int)] +f ( - (3::Int)) == Left (3::Int)&& f (4::Int)== Right (4::Int) +f ( 7::Int ) ( 7::Int ) && not ( f ( 7::Int ) ( 6::Int ) ) +f ( Left ( - (3::Int)) ) == (3::Int)&& f ( Right (4::Int)) == (4::Int) +f ( succ :: Int -> Int ) (1::Int)== (2::Int) +f (3::Int)"abcde" == 'd' +f (3::Int)(5::Int)== [ (3::Int), (4::Int), (5::Int)] +f (4::Int)== (24::Int)&& f (5::Int)== (25::Int) +f (4::Int)[ (1::Int), (2::Int), (3::Int)] == (10::Int) +f == [ (1::Int), (3::Int)] +f True True == True && f False False == True +f [ "ABCDE" , "DF" , "1234" , "" ] == [ "" , "DF" , "1234" , "ABCDE" ] +f [ ( 'a' , (1::Int)) , ( 'b' , (2::Int)) ] 'b' == Just (2::Int) +f [ ( (3::Int)* ) , ( (4::Int)+ ) ] (8::Int)== [ (24::Int), (12::Int)] +f [ ( (3::Int)+ ) , ( * (8::Int)) ] [ (2::Int), (4::Int)] == [ (5::Int), (32::Int)] +f [ ( 6::Int ) , ( 5::Int ) , ( 5::Int ) , ( 3::Int ) , ( 6::Int ) ] == [ ( 3::Int ) , ( 5::Int ) , ( 6::Int ) ] +f [ (1::Int), (2::Int), (1::Int), (1::Int)] ~= 0.2 +f [ (1::Int), (2::Int), (1::Int), (1::Int)] ~= [ 0.2 , 3.0 ] +f [ (1::Int), (2::Int), (2::Int), (3::Int), (3::Int), (3::Int), (2::Int), (2::Int), (2::Int)] == [ (1::Int), (2::Int), (3::Int)] +f [ (1::Int), (2::Int), (2::Int), (3::Int), (3::Int), (3::Int), (2::Int), (2::Int), (2::Int)] == [ [ (1::Int)] , [ (2::Int), (2::Int)] , [ (3::Int), (3::Int), (3::Int)] , [ (2::Int), (2::Int), (2::Int)] ] +f [ (1::Int).. (5::Int)] == (4::Int)&& f [ - (2::Int), - (3::Int)] == ( - (2::Int)) +f [ (3::Int), (4::Int)] [ (4::Int), (5::Int)] == [ (7::Int), (9::Int)] +f [ True ] [ True ] && not ( f [ True ] [ False ] ) +length ( f :: String ) == ( 1::Int ) +f [3, 4.5, 7.5] ~= 5.0 +f 3.54 ~= 3.5 +f [3,4,0.2] ~= [9,16,0.04] +f 3.7 ~= 4 +f [3, 4] [5, 6] ~= [3.5, 4.6] +( f "abc" 'c' == 3 ) && f "Abc\nd Ef" 'b' == 2 +( f ( + 4 ) ( Just 6 ) == ( Just 10 ) ) && f id ( Just ( - 1 ) ) ~= Just ( - 1 ) +f "123" == 'a' +f 32 == ' ' +( ( ( ( ( f "kristoffer" "reffotsirk" == True ) && f "" "\nm Z" ~= False ) && f "\nm Z" "" ~= False ) && f "" " +" ~= True ) && f "\nm Z" "\nm Z" ~= False ) && f "" "12345" ~= False +f "ancd ed ad e ww" == [ 15 , 5 ] +f "a" == f "a" +f "lollolabacad" 2 ~= "ollbcd" +f ( + 4 ) ( Just ( Just 6 ) ) == Just ( Just 10 ) +f ( 1 , 'a' ) ~= ( 3 , 'c' ) +f 1 'a' ~= ( 2 , 'b' ) +f 'a' ~= 'b' +f ( Left 3 ) == 3 && f ( Right 4 ) == 4 +f 1 ( Just 1 ) ( Just ( Just 1 ) ) ( Just ( Just ( Just 1 ) ) ) ( Just ( Just ( Just ( Just 1 ) ) ) ) ( Just ( +Just ( Just ( Just ( Just 1 ) ) ) ) ) == 1 +f 1 [ 1 ] [ [ 1 ] ] [ [ [ 1 ] ] ] [ [ [ [ 1 ] ] ] ] [ [ [ [ [ 1 ] ] ] ] ] == 1 +f 1 ~= [ [ ] ] && f 2 ~= [ [ [ ] ] , [ ] ] +f 2 ( ) == 1 +f 2 [ 1 , 2 ] == [ [ 1 , 1 ] , [ 1 , 2 ] , [ 2 , 1 ] , [ 2 , 2 ] ] +f 3 == [ "a" , "b" , "c" ] +( f "abc" 'c' == 3 ) && f "Abc\nd Ef" 'b' == 2 +f 'a' == [ "a" , "b" , "c" ] +f 3 [ 1 , 2 , 4 , 7 ] == [ 1 , 2 , 3 , 4 , 7 ] +f [ "a" , "b" , "c" , "d" ] ~= "e" +f [ 0 , 1 , 2 , 3 , 4 , 5 , 6 , 7 ] == [ "000" , "001" , "011" , "010" , "110" , "111" , "101" , "100" ] +f [ 1 , 2 ] [ 3 , 4 ] ~= [ [ 1 , 3 ] , [ 1 , 4 ] , [ 2 , 3 ] , [ 2 , 4 ] ] +f [ Nothing , Nothing , Just "a" , Just "b" ] == "a" +f [ const 3 , head , ( sum . take 2 ) ] == [ 3 , 3 , 6 ] +f [ f [ 3 , 4 , 5 ] + 5 ] ~= 12.1 +fmap f [ 1 , 2 , 3 , 4 ] ~= [ sinh 1 , cosh 2 , sinh 3 , cosh 4 ] diff --git a/xlmap b/xlmap new file mode 100644 --- /dev/null +++ b/xlmap @@ -0,0 +1,1 @@ +[("SUM","SUM-function-043e1c7d-7726-4e80-8f32-07b23e057f89"),("IF","IF-function-69aed7c9-4e8a-4755-a9bc-aa8bbff73be2"),("LOOKUP","LOOKUP-function-446d94af-663b-451d-8251-369d5e3864cb"),("VLOOKUP","VLOOKUP-function-0bbc8083-26fe-4963-8ab8-93a18ad188a1"),("MATCH","MATCH-function-e8dffd45-c762-47d6-bf89-533f4a37673a"),("CHOOSE","CHOOSE-function-fc5c184f-cb62-4ec7-a46e-38653b98f5bc"),("DATE","DATE-function-e36c0c8c-4104-49da-ab83-82328b832349"),("DAYS","DAYS-function-57740535-d549-4395-8728-0f07bff0b9df"),("FIND","FIND-FINDB-functions-c7912941-af2a-4bdf-a553-d0d89b0a0628"),("FINDB","FIND-FINDB-functions-c7912941-af2a-4bdf-a553-d0d89b0a0628"),("INDEX","INDEX-function-a5dcf0dd-996d-40a4-a822-b56b061328bd"),("BETADIST","BETADIST-function-49f1b9a9-a5da-470f-8077-5f1730b5fd47"),("BETAINV","BETAINV-function-8b914ade-b902-43c1-ac9c-c05c54f10d6c"),("BINOMDIST","BINOMDIST-function-506a663e-c4ca-428d-b9a8-05583d68789c"),("CHIDIST","CHIDIST-function-c90d0fbc-5b56-4f5f-ab57-34af1bf6897e"),("CHIINV","CHIINV-function-cfbea3f6-6e4f-40c9-a87f-20472e0512af"),("CHITEST","CHITEST-function-981ff871-b694-4134-848e-38ec704577ac"),("CONFIDENCE","CONFIDENCE-function-75ccc007-f77c-4343-bc14-673642091ad6"),("COVAR","COVAR-function-50479552-2c03-4daf-bd71-a5ab88b2db03"),("CRITBINOM","CRITBINOM-function-eb6b871d-796b-4d21-b69b-e4350d5f407b"),("EXPONDIST","EXPONDIST-function-68ab45fd-cd6d-4887-9770-9357eb8ee06a"),("FDIST","FDIST-function-ecf76fba-b3f1-4e7d-a57e-6a5b7460b786"),("FINV","FINV-function-4d46c97c-c368-4852-bc15-41e8e31140b1"),("FLOOR","FLOOR-function-14bb497c-24f2-4e04-b327-b0b4de5a8886"),("FTEST","FTEST-function-4c9e1202-53fe-428c-a737-976f6fc3f9fd"),("GAMMADIST","GAMMADIST-function-7327c94d-0f05-4511-83df-1dd7ed23e19e"),("GAMMAINV","GAMMAINV-function-06393558-37ab-47d0-aa63-432f99e7916d"),("HYPGEOMDIST","HYPGEOMDIST-function-23e37961-2871-4195-9629-d0b2c108a12e"),("LOGINV","LOGINV-function-0bd7631a-2725-482b-afb4-de23df77acfe"),("LOGNORMDIST","LOGNORMDIST-function-f8d194cb-9ee3-4034-8c75-1bdb3884100b"),("MODE","MODE-function-e45192ce-9122-4980-82ed-4bdc34973120"),("NEGBINOMDIST","NEGBINOMDIST-function-f59b0a37-bae2-408d-b115-a315609ba714"),("NORMDIST","NORMDIST-function-126db625-c53e-4591-9a22-c9ff422d6d58"),("NORMINV","NORMINV-function-87981ab8-2de0-4cb0-b1aa-e21d4cb879b8"),("NORMSDIST","NORMSDIST-function-463369ea-0345-445d-802a-4ff0d6ce7cac"),("NORMSINV","NORMSINV-function-8d1bce66-8e4d-4f3b-967c-30eed61f019d"),("PERCENTILE","PERCENTILE-function-91b43a53-543c-4708-93de-d626debdddca"),("PERCENTRANK","PERCENTRANK-function-f1b5836c-9619-4847-9fc9-080ec9024442"),("POISSON","POISSON-function-d81f7294-9d7c-4f75-bc23-80aa8624173a"),("QUARTILE","QUARTILE-function-93cf8f62-60cd-4fdb-8a92-8451041e1a2a"),("RANK","RANK-function-6a2fc49d-1831-4a03-9d8c-c279cf99f723"),("STDEV","STDEV-function-51fecaaa-231e-4bbb-9230-33650a72c9b0"),("STDEVP","STDEVP-function-1f7c1c88-1bec-4422-8242-e9f7dc8bb195"),("TDIST","TDIST-function-630a7695-4021-4853-9468-4a1f9dcdd192"),("TINV","TINV-function-a7c85b9d-90f5-41fe-9ca5-1cd2f3e1ed7c"),("TTEST","TTEST-function-1696ffc1-4811-40fd-9d13-a0eaad83c7ae"),("VAR","VAR-function-1f2b7ab2-954d-4e17-ba2c-9e58b15a7da2"),("VARP","VARP-function-26a541c4-ecee-464d-a731-bd4c575b1a6b"),("WEIBULL","WEIBULL-function-b83dc2c6-260b-4754-bef2-633196f6fdcc"),("ZTEST","ZTEST-function-8f33be8a-6bd6-4ecc-8e3a-d9a4420c4a6a"),("CUBEKPIMEMBER","CUBEKPIMEMBER-function-744608bf-2c62-42cd-b67a-a56109f4b03b"),("CUBEMEMBER","CUBEMEMBER-function-0f6a15b9-2c18-4819-ae89-e1b5c8b398ad"),("CUBEMEMBERPROPERTY","CUBEMEMBERPROPERTY-function-001e57d6-b35a-49e5-abcd-05ff599e8951"),("CUBERANKEDMEMBER","CUBERANKEDMEMBER-function-07efecde-e669-4075-b4bf-6b40df2dc4b3"),("CUBESET","CUBESET-function-5b2146bd-62d6-4d04-9d8f-670e993ee1d9"),("CUBESETCOUNT","CUBESETCOUNT-function-c4c2a438-c1ff-4061-80fe-982f2d705286"),("CUBEVALUE","CUBEVALUE-function-8733da24-26d1-4e34-9b3a-84a8f00dcbe0"),("DAVERAGE","DAVERAGE-function-a6a2d5ac-4b4b-48cd-a1d8-7b37834e5aee"),("DCOUNT","DCOUNT-function-c1fc7b93-fb0d-4d8d-97db-8d5f076eaeb1"),("DCOUNTA","DCOUNTA-function-00232a6d-5a66-4a01-a25b-c1653fda1244"),("DGET","DGET-function-455568bf-4eef-45f7-90f0-ec250d00892e"),("DMAX","DMAX-function-f4e8209d-8958-4c3d-a1ee-6351665d41c2"),("DMIN","DMIN-function-4ae6f1d9-1f26-40f1-a783-6dc3680192a3"),("DPRODUCT","DPRODUCT-function-4f96b13e-d49c-47a7-b769-22f6d017cb31"),("DSTDEV","DSTDEV-function-026b8c73-616d-4b5e-b072-241871c4ab96"),("DSTDEVP","DSTDEVP-function-04b78995-da03-4813-bbd9-d74fd0f5d94b"),("DSUM","DSUM-function-53181285-0c4b-4f5a-aaa3-529a322be41b"),("DVAR","DVAR-function-d6747ca9-99c7-48bb-996e-9d7af00f3ed1"),("DVARP","DVARP-function-eb0ba387-9cb7-45c8-81e9-0394912502fc"),("DATE","DATE-function-e36c0c8c-4104-49da-ab83-82328b832349"),("DATEDIF","DATEDIF-function-25dba1a4-2812-480b-84dd-8b32a451b35c"),("DATEVALUE","DATEVALUE-function-df8b07d4-7761-4a93-bc33-b7471bbff252"),("DAY","DAY-function-8a7d1cbb-6c7d-4ba1-8aea-25c134d03101"),("DAYS","DAYS-function-57740535-d549-4395-8728-0f07bff0b9df"),("DAYS360","DAYS360-function-b9a509fd-49ef-407e-94df-0cbda5718c2a"),("EDATE","EDATE-function-3c920eb2-6e66-44e7-a1f5-753ae47ee4f5"),("EOMONTH","EOMONTH-function-7314ffa1-2bc9-4005-9d66-f49db127d628"),("HOUR","HOUR-function-a3afa879-86cb-4339-b1b5-2dd2d7310ac7"),("ISOWEEKNUM","ISOWEEKNUM-function-1c2d0afe-d25b-4ab1-8894-8d0520e90e0e"),("MINUTE","MINUTE-function-af728df0-05c4-4b07-9eed-a84801a60589"),("MONTH","MONTH-function-579a2881-199b-48b2-ab90-ddba0eba86e8"),("NETWORKDAYS","NETWORKDAYS-function-48e717bf-a7a3-495f-969e-5005e3eb18e7"),("NETWORKDAYS.INTL","NETWORKDAYSINTL-function-a9b26239-4f20-46a1-9ab8-4e925bfd5e28"),("NOW","NOW-function-3337fd29-145a-4347-b2e6-20c904739c46"),("SECOND","SECOND-function-740d1cfc-553c-4099-b668-80eaa24e8af1"),("TIME","TIME-function-9a5aff99-8f7d-4611-845e-747d0b8d5457"),("TIMEVALUE","TIMEVALUE-function-0b615c12-33d8-4431-bf3d-f3eb6d186645"),("TODAY","TODAY-function-5eb3078d-a82c-4736-8930-2f51a028fdd9"),("WEEKDAY","WEEKDAY-function-60e44483-2ed1-439f-8bd0-e404c190949a"),("WEEKNUM","WEEKNUM-function-e5c43a03-b4ab-426c-b411-b18c13c75340"),("WORKDAY","WORKDAY-function-f764a5b7-05fc-4494-9486-60d494efbf33"),("WORKDAY.INTL","WORKDAYINTL-function-a378391c-9ba7-4678-8a39-39611a9bf81d"),("YEAR","YEAR-function-c64f017a-1354-490d-981f-578e8ec8d3b9"),("YEARFRAC","YEARFRAC-function-3844141e-c76d-4143-82b6-208454ddc6a8"),("BESSELI","BESSELI-function-8d33855c-9a8d-444b-98e0-852267b1c0df"),("BESSELJ","BESSELJ-function-839cb181-48de-408b-9d80-bd02982d94f7"),("BESSELK","BESSELK-function-606d11bc-06d3-4d53-9ecb-2803e2b90b70"),("BESSELY","BESSELY-function-f3a356b3-da89-42c3-8974-2da54d6353a2"),("BIN2DEC","BIN2DEC-function-63905b57-b3a0-453d-99f4-647bb519cd6c"),("BIN2HEX","BIN2HEX-function-0375e507-f5e5-4077-9af8-28d84f9f41cc"),("BIN2OCT","BIN2OCT-function-0a4e01ba-ac8d-4158-9b29-16c25c4c23fd"),("BITAND","BITAND-function-8a2be3d7-91c3-4b48-9517-64548008563a"),("BITLSHIFT","BITLSHIFT-function-c55bb27e-cacd-4c7c-b258-d80861a03c9c"),("BITOR","BITOR-function-f6ead5c8-5b98-4c9e-9053-8ad5234919b2"),("BITRSHIFT","BITRSHIFT-function-274d6996-f42c-4743-abdb-4ff95351222c"),("BITXOR","BITXOR-function-c81306a1-03f9-4e89-85ac-b86c3cba10e4"),("COMPLEX","COMPLEX-function-f0b8f3a9-51cc-4d6d-86fb-3a9362fa4128"),("CONVERT","CONVERT-function-d785bef1-808e-4aac-bdcd-666c810f9af2"),("DEC2BIN","DEC2BIN-function-0f63dd0e-5d1a-42d8-b511-5bf5c6d43838"),("DEC2HEX","DEC2HEX-function-6344ee8b-b6b5-4c6a-a672-f64666704619"),("DEC2OCT","DEC2OCT-function-c9d835ca-20b7-40c4-8a9e-d3be351ce00f"),("DELTA","DELTA-function-2f763672-c959-4e07-ac33-fe03220ba432"),("ERF","ERF-function-c53c7e7b-5482-4b6c-883e-56df3c9af349"),("ERF.PRECISE","ERFPRECISE-function-9a349593-705c-4278-9a98-e4122831a8e0"),("ERFC","ERFC-function-736e0318-70ba-4e8b-8d08-461fe68b71b3"),("ERFC.PRECISE","ERFCPRECISE-function-e90e6bab-f45e-45df-b2ac-cd2eb4d4a273"),("GESTEP","GESTEP-function-f37e7d2a-41da-4129-be95-640883fca9df"),("HEX2BIN","HEX2BIN-function-a13aafaa-5737-4920-8424-643e581828c1"),("HEX2DEC","HEX2DEC-function-8c8c3155-9f37-45a5-a3ee-ee5379ef106e"),("HEX2OCT","HEX2OCT-function-54d52808-5d19-4bd0-8a63-1096a5d11912"),("IMABS","IMABS-function-b31e73c6-d90c-4062-90bc-8eb351d765a1"),("IMAGINARY","IMAGINARY-function-dd5952fd-473d-44d9-95a1-9a17b23e428a"),("IMARGUMENT","IMARGUMENT-function-eed37ec1-23b3-4f59-b9f3-d340358a034a"),("IMCONJUGATE","IMCONJUGATE-function-2e2fc1ea-f32b-4f9b-9de6-233853bafd42"),("IMCOS","IMCOS-function-dad75277-f592-4a6b-ad6c-be93a808a53c"),("IMCOSH","IMCOSH-function-053e4ddb-4122-458b-be9a-457c405e90ff"),("IMCOT","IMCOT-function-dc6a3607-d26a-4d06-8b41-8931da36442c"),("IMCSC","IMCSC-function-9e158d8f-2ddf-46cd-9b1d-98e29904a323"),("IMCSCH","IMCSCH-function-c0ae4f54-5f09-4fef-8da0-dc33ea2c5ca9"),("IMDIV","IMDIV-function-a505aff7-af8a-4451-8142-77ec3d74d83f"),("IMEXP","IMEXP-function-c6f8da1f-e024-4c0c-b802-a60e7147a95f"),("IMLN","IMLN-function-32b98bcf-8b81-437c-a636-6fb3aad509d8"),("IMLOG10","IMLOG10-function-58200fca-e2a2-4271-8a98-ccd4360213a5"),("IMLOG2","IMLOG2-function-152e13b4-bc79-486c-a243-e6a676878c51"),("IMPOWER","IMPOWER-function-210fd2f5-f8ff-4c6a-9d60-30e34fbdef39"),("IMPRODUCT","IMPRODUCT-function-2fb8651a-a4f2-444f-975e-8ba7aab3a5ba"),("IMREAL","IMREAL-function-d12bc4c0-25d0-4bb3-a25f-ece1938bf366"),("IMSEC","IMSEC-function-6df11132-4411-4df4-a3dc-1f17372459e0"),("IMSECH","IMSECH-function-f250304f-788b-4505-954e-eb01fa50903b"),("IMSIN","IMSIN-function-1ab02a39-a721-48de-82ef-f52bf37859f6"),("IMSINH","IMSINH-function-dfb9ec9e-8783-4985-8c42-b028e9e8da3d"),("IMSQRT","IMSQRT-function-e1753f80-ba11-4664-a10e-e17368396b70"),("IMSUB","IMSUB-function-2e404b4d-4935-4e85-9f52-cb08b9a45054"),("IMSUM","IMSUM-function-81542999-5f1c-4da6-9ffe-f1d7aaa9457f"),("IMTAN","IMTAN-function-8478f45d-610a-43cf-8544-9fc0b553a132"),("OCT2BIN","OCT2BIN-function-55383471-3c56-4d27-9522-1a8ec646c589"),("OCT2DEC","OCT2DEC-function-87606014-cb98-44b2-8dbb-e48f8ced1554"),("OCT2HEX","OCT2HEX-function-912175b4-d497-41b4-a029-221f051b858f"),("ACCRINT","ACCRINT-function-fe45d089-6722-4fb3-9379-e1f911d8dc74"),("ACCRINTM","ACCRINTM-function-f62f01f9-5754-4cc4-805b-0e70199328a7"),("AMORDEGRC","AMORDEGRC-function-a14d0ca1-64a4-42eb-9b3d-b0dededf9e51"),("AMORLINC","AMORLINC-function-7d417b45-f7f5-4dba-a0a5-3451a81079a8"),("COUPDAYBS","COUPDAYBS-function-eb9a8dfb-2fb2-4c61-8e5d-690b320cf872"),("COUPDAYS","COUPDAYS-function-cc64380b-315b-4e7b-950c-b30b0a76f671"),("COUPDAYSNC","COUPDAYSNC-function-5ab3f0b2-029f-4a8b-bb65-47d525eea547"),("COUPNCD","COUPNCD-function-fd962fef-506b-4d9d-8590-16df5393691f"),("COUPNUM","COUPNUM-function-a90af57b-de53-4969-9c99-dd6139db2522"),("COUPPCD","COUPPCD-function-2eb50473-6ee9-4052-a206-77a9a385d5b3"),("CUMIPMT","CUMIPMT-function-61067bb0-9016-427d-b95b-1a752af0e606"),("CUMPRINC","CUMPRINC-function-94a4516d-bd65-41a1-bc16-053a6af4c04d"),("DB","DB-function-354e7d28-5f93-4ff1-8a52-eb4ee549d9d7"),("DDB","DDB-function-519a7a37-8772-4c96-85c0-ed2c209717a5"),("DISC","DISC-function-71fce9f3-3f05-4acf-a5a3-eac6ef4daa53"),("DOLLARDE","DOLLARDE-function-db85aab0-1677-428a-9dfd-a38476693427"),("DOLLARFR","DOLLARFR-function-0835d163-3023-4a33-9824-3042c5d4f495"),("DURATION","DURATION-function-b254ea57-eadc-4602-a86a-c8e369334038"),("EFFECT","EFFECT-function-910d4e4c-79e2-4009-95e6-507e04f11bc4"),("FV","FV-function-2eef9f44-a084-4c61-bdd8-4fe4bb1b71b3"),("FVSCHEDULE","FVSCHEDULE-function-bec29522-bd87-4082-bab9-a241f3fb251d"),("INTRATE","INTRATE-function-5cb34dde-a221-4cb6-b3eb-0b9e55e1316f"),("IPMT","IPMT-function-5cce0ad6-8402-4a41-8d29-61a0b054cb6f"),("IRR","IRR-function-64925eaa-9988-495b-b290-3ad0c163c1bc"),("ISPMT","ISPMT-function-fa58adb6-9d39-4ce0-8f43-75399cea56cc"),("MDURATION","MDURATION-function-b3786a69-4f20-469a-94ad-33e5b90a763c"),("MIRR","MIRR-function-b020f038-7492-4fb4-93c1-35c345b53524"),("NOMINAL","NOMINAL-function-7f1ae29b-6b92-435e-b950-ad8b190ddd2b"),("NPER","NPER-function-240535b5-6653-4d2d-bfcf-b6a38151d815"),("NPV","NPV-function-8672cb67-2576-4d07-b67b-ac28acf2a568"),("ODDFPRICE","ODDFPRICE-function-d7d664a8-34df-4233-8d2b-922bcf6a69e1"),("ODDFYIELD","ODDFYIELD-function-66bc8b7b-6501-4c93-9ce3-2fd16220fe37"),("ODDLPRICE","ODDLPRICE-function-fb657749-d200-4902-afaf-ed5445027fc4"),("ODDLYIELD","ODDLYIELD-function-c873d088-cf40-435f-8d41-c8232fee9238"),("PDURATION","PDURATION-function-44f33460-5be5-4c90-b857-22308892adaf"),("PMT","PMT-function-0214da64-9a63-4996-bc20-214433fa6441"),("PPMT","PPMT-function-c370d9e3-7749-4ca4-beea-b06c6ac95e1b"),("PRICE","PRICE-function-3ea9deac-8dfa-436f-a7c8-17ea02c21b0a"),("PRICEDISC","PRICEDISC-function-d06ad7c1-380e-4be7-9fd9-75e3079acfd3"),("PRICEMAT","PRICEMAT-function-52c3b4da-bc7e-476a-989f-a95f675cae77"),("PV","PV-function-23879d31-0e02-4321-be01-da16e8168cbd"),("RATE","RATE-function-9f665657-4a7e-4bb7-a030-83fc59e748ce"),("RECEIVED","RECEIVED-function-7a3f8b93-6611-4f81-8576-828312c9b5e5"),("RRI","RRI-function-6f5822d8-7ef1-4233-944c-79e8172930f4"),("SLN","SLN-function-cdb666e5-c1c6-40a7-806a-e695edc2f1c8"),("SYD","SYD-function-069f8106-b60b-4ca2-98e0-2a0f206bdb27"),("TBILLEQ","TBILLEQ-function-2ab72d90-9b4d-4efe-9fc2-0f81f2c19c8c"),("TBILLPRICE","TBILLPRICE-function-eacca992-c29d-425a-9eb8-0513fe6035a2"),("TBILLYIELD","TBILLYIELD-function-6d381232-f4b0-4cd5-8e97-45b9c03468ba"),("VDB","VDB-function-dde4e207-f3fa-488d-91d2-66d55e861d73"),("XIRR","XIRR-function-de1242ec-6477-445b-b11b-a303ad9adc9d"),("XNPV","XNPV-function-1b42bbf6-370f-4532-a0eb-d67c16b664b7"),("YIELD","YIELD-function-f5f5ca43-c4bd-434f-8bd2-ed3c9727a4fe"),("YIELDDISC","YIELDDISC-function-a9dbdbae-7dae-46de-b995-615faffaaed7"),("YIELDMAT","YIELDMAT-function-ba7d1809-0d33-4bcb-96c7-6c56ec62ef6f"),("CELL","CELL-function-51bd39a5-f338-4dbe-a33f-955d67c2b2cf"),("ERROR.TYPE","ERRORTYPE-function-10958677-7c8d-44f7-ae77-b9a9ee6eefaa"),("INFO","INFO-function-725f259a-0e4b-49b3-8b52-58815c69acae"),("ISBLANK","ISBLANK-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISERR","ISERR-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISERROR","ISERROR-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISEVEN","ISEVEN-function-aa15929a-d77b-4fbb-92f4-2f479af55356"),("ISFORMULA","ISFORMULA-function-e4d1355f-7121-4ef2-801e-3839bfd6b1e5"),("ISLOGICAL","ISLOGICAL-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISNA","ISNA-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISNONTEXT","ISNONTEXT-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISNUMBER","ISNUMBER-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISODD","ISODD-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISREF","ISREF-function-0f2d7971-6019-40a0-a171-f2d869135665"),("ISTEXT","ISTEXT-function-0f2d7971-6019-40a0-a171-f2d869135665"),("N","N-function-a624cad1-3635-4208-b54a-29733d1278c9"),("NA","NA-function-5469c2d1-a90c-4fb5-9bbc-64bd9bb6b47c"),("SHEET","SHEET-function-44718b6f-8b87-47a1-a9d6-b701c06cff24"),("SHEETS","SHEETS-function-770515eb-e1e8-45ce-8066-b557e5e4b80b"),("TYPE","TYPE-function-45b4e688-4bc3-48b3-a105-ffa892995899"),("AND","AND-function-5f19b2e8-e1df-4408-897a-ce285a19e9d9"),("FALSE","FALSE-function-2d58dfa5-9c03-4259-bf8f-f0ae14346904"),("IF","IF-function-69aed7c9-4e8a-4755-a9bc-aa8bbff73be2"),("IFERROR","IFERROR-function-c526fd07-caeb-47b8-8bb6-63f3e417f611"),("IFNA","IFNA-function-6626c961-a569-42fc-a49d-79b4951fd461"),("NOT","NOT-function-9cfc6011-a054-40c7-a140-cd4ba2d87d77"),("OR","OR-function-7d17ad14-8700-4281-b308-00b131e22af0"),("TRUE","TRUE-function-7652c6e3-8987-48d0-97cd-ef223246b3fb"),("XOR","XOR-function-1548d4c2-5e47-4f77-9a92-0533bba14f37"),("ADDRESS","ADDRESS-function-d0c26c0d-3991-446b-8de4-ab46431d4f89"),("AREAS","AREAS-function-8392ba32-7a41-43b3-96b0-3695d2ec6152"),("CHOOSE","CHOOSE-function-fc5c184f-cb62-4ec7-a46e-38653b98f5bc"),("COLUMN","COLUMN-function-44e8c754-711c-4df3-9da4-47a55042554b"),("COLUMNS","COLUMNS-function-4e8e7b4e-e603-43e8-b177-956088fa48ca"),("FORMULATEXT","FORMULATEXT-function-0a786771-54fd-4ae2-96ee-09cda35439c8"),("GETPIVOTDATA","GETPIVOTDATA-function-8c083b99-a922-4ca0-af5e-3af55960761f"),("HLOOKUP","HLOOKUP-function-a3034eec-b719-4ba3-bb65-e1ad662ed95f"),("HYPERLINK","HYPERLINK-function-333c7ce6-c5ae-4164-9c47-7de9b76f577f"),("INDEX","INDEX-function-a5dcf0dd-996d-40a4-a822-b56b061328bd"),("INDIRECT","INDIRECT-function-474b3a3a-8a26-4f44-b491-92b6306fa261"),("LOOKUP","LOOKUP-function-446d94af-663b-451d-8251-369d5e3864cb"),("MATCH","MATCH-function-e8dffd45-c762-47d6-bf89-533f4a37673a"),("OFFSET","OFFSET-function-c8de19ae-dd79-4b9b-a14e-b4d906d11b66"),("ROW","ROW-function-3a63b74a-c4d0-4093-b49a-e76eb49a6d8d"),("ROWS","ROWS-function-b592593e-3fc2-47f2-bec1-bda493811597"),("RTD","RTD-function-e0cc001a-56f0-470a-9b19-9455dc0eb593"),("TRANSPOSE","TRANSPOSE-function-ed039415-ed8a-4a81-93e9-4b6dfac76027"),("VLOOKUP","VLOOKUP-function-0bbc8083-26fe-4963-8ab8-93a18ad188a1"),("ABS","ABS-function-3420200f-5628-4e8c-99da-c99d7c87713c"),("ACOS","ACOS-function-cb73173f-d089-4582-afa1-76e5524b5d5b"),("ACOSH","ACOSH-function-e3992cc1-103f-4e72-9f04-624b9ef5ebfe"),("ACOT","ACOT-function-dc7e5008-fe6b-402e-bdd6-2eea8383d905"),("ACOTH","ACOTH-function-cc49480f-f684-4171-9fc5-73e4e852300f"),("AGGREGATE","AGGREGATE-function-43b9278e-6aa7-4f17-92b6-e19993fa26df"),("ARABIC","ARABIC-function-9a8da418-c17b-4ef9-a657-9370a30a674f"),("ASIN","ASIN-function-81fb95e5-6d6f-48c4-bc45-58f955c6d347"),("ASINH","ASINH-function-4e00475a-067a-43cf-926a-765b0249717c"),("ATAN","ATAN-function-50746fa8-630a-406b-81d0-4a2aed395543"),("ATAN2","ATAN2-function-c04592ab-b9e3-4908-b428-c96b3a565033"),("ATANH","ATANH-function-3cd65768-0de7-4f1d-b312-d01c8c930d90"),("BASE","BASE-function-2ef61411-aee9-4f29-a811-1c42456c6342"),("CEILING","CEILING-function-0a5cd7c8-0720-4f0a-bd2c-c943e510899f"),("CEILING.MATH","CEILINGMATH-function-80f95d2f-b499-4eee-9f16-f795a8e306c8"),("CEILING.PRECISE","CEILINGPRECISE-function-f366a774-527a-4c92-ba49-af0a196e66cb"),("COMBIN","COMBIN-function-12a3f276-0a21-423a-8de6-06990aaf638a"),("COMBINA","COMBINA-function-efb49eaa-4f4c-4cd2-8179-0ddfcf9d035d"),("COS","COS-function-0fb808a5-95d6-4553-8148-22aebdce5f05"),("COSH","COSH-function-e460d426-c471-43e8-9540-a57ff3b70555"),("COT","COT-function-c446f34d-6fe4-40dc-84f8-cf59e5f5e31a"),("COTH","COTH-function-2e0b4cb6-0ba0-403e-aed4-deaa71b49df5"),("CSC","CSC-function-07379361-219a-4398-8675-07ddc4f135c1"),("CSCH","CSCH-function-f58f2c22-eb75-4dd6-84f4-a503527f8eeb"),("DECIMAL","DECIMAL-function-ee554665-6176-46ef-82de-0a283658da2e"),("DEGREES","DEGREES-function-4d6ec4db-e694-4b94-ace0-1cc3f61f9ba1"),("EVEN","EVEN-function-197b5f06-c795-4c1e-8696-3c3b8a646cf9"),("EXP","EXP-function-c578f034-2c45-4c37-bc8c-329660a63abe"),("FACT","FACT-function-ca8588c2-15f2-41c0-8e8c-c11bd471a4f3"),("FACTDOUBLE","FACTDOUBLE-function-e67697ac-d214-48eb-b7b7-cce2589ecac8"),("FLOOR","FLOOR-function-14bb497c-24f2-4e04-b327-b0b4de5a8886"),("FLOOR.MATH","FLOORMATH-function-c302b599-fbdb-4177-ba19-2c2b1249a2f5"),("FLOOR.PRECISE","FLOORPRECISE-function-f769b468-1452-4617-8dc3-02f842a0702e"),("GCD","GCD-function-d5107a51-69e3-461f-8e4c-ddfc21b5073a"),("INT","INT-function-a6c4af9e-356d-4369-ab6a-cb1fd9d343ef"),("ISO.CEILING","ISOCEILING-function-e587bb73-6cc2-4113-b664-ff5b09859a83"),("LCM","LCM-function-7152b67a-8bb5-4075-ae5c-06ede5563c94"),("LN","LN-function-81fe1ed7-dac9-4acd-ba1d-07a142c6118f"),("LOG","LOG-function-4e82f196-1ca9-4747-8fb0-6c4a3abb3280"),("LOG10","LOG10-function-c75b881b-49dd-44fb-b6f4-37e3486a0211"),("MDETERM","MDETERM-function-e7bfa857-3834-422b-b871-0ffd03717020"),("MINVERSE","MINVERSE-function-11f55086-adde-4c9f-8eb9-59da2d72efc6"),("MMULT","MMULT-function-40593ed7-a3cd-4b6b-b9a3-e4ad3c7245eb"),("MOD","MOD-function-9b6cd169-b6ee-406a-a97b-edf2a9dc24f3"),("MROUND","MROUND-function-c299c3b0-15a5-426d-aa4b-d2d5b3baf427"),("MULTINOMIAL","MULTINOMIAL-function-6fa6373c-6533-41a2-a45e-a56db1db1bf6"),("MUNIT","MUNIT-function-c9fe916a-dc26-4105-997d-ba22799853a3"),("ODD","ODD-function-deae64eb-e08a-4c88-8b40-6d0b42575c98"),("PI","PI-function-264199d0-a3ba-46b8-975a-c4a04608989b"),("POWER","POWER-function-d3f2908b-56f4-4c3f-895a-07fb519c362a"),("PRODUCT","PRODUCT-function-8e6b5b24-90ee-4650-aeec-80982a0512ce"),("QUOTIENT","QUOTIENT-function-9f7bf099-2a18-4282-8fa4-65290cc99dee"),("RADIANS","RADIANS-function-ac409508-3d48-45f5-ac02-1497c92de5bf"),("RAND","RAND-function-4cbfa695-8869-4788-8d90-021ea9f5be73"),("RANDBETWEEN","RANDBETWEEN-function-4cc7f0d1-87dc-4eb7-987f-a469ab381685"),("ROMAN","ROMAN-function-d6b0b99e-de46-4704-a518-b45a0f8b56f5"),("ROUND","ROUND-function-c018c5d8-40fb-4053-90b1-b3e7f61a213c"),("ROUNDDOWN","ROUNDDOWN-function-2ec94c73-241f-4b01-8c6f-17e6d7968f53"),("ROUNDUP","ROUNDUP-function-f8bc9b23-e795-47db-8703-db171d0c42a7"),("SEC","SEC-function-ff224717-9c87-4170-9b58-d069ced6d5f7"),("SECH","SECH-function-e05a789f-5ff7-4d7f-984a-5edb9b09556f"),("SERIESSUM","SERIESSUM-function-a3ab25b5-1093-4f5b-b084-96c49087f637"),("SIGN","SIGN-function-109c932d-fcdc-4023-91f1-2dd0e916a1d8"),("SIN","SIN-function-cf0e3432-8b9e-483c-bc55-a76651c95602"),("SINH","SINH-function-1e4e8b9f-2b65-43fc-ab8a-0a37f4081fa7"),("SQRT","SQRT-function-654975c2-05c4-4831-9a24-2c65e4040fdf"),("SQRTPI","SQRTPI-function-1fb4e63f-9b51-46d6-ad68-b3e7a8b519b4"),("SUBTOTAL","SUBTOTAL-function-7b027003-f060-4ade-9040-e478765b9939"),("SUM","SUM-function-043e1c7d-7726-4e80-8f32-07b23e057f89"),("SUMIF","SUMIF-function-169b8c99-c05c-4483-a712-1697a653039b"),("SUMIFS","SUMIFS-function-c9e748f5-7ea7-455d-9406-611cebce642b"),("SUMPRODUCT","SUMPRODUCT-function-16753e75-9f68-4874-94ac-4d2145a2fd2e"),("SUMSQ","SUMSQ-function-e3313c02-51cc-4963-aae6-31442d9ec307"),("SUMX2MY2","SUMX2MY2-function-9e599cc5-5399-48e9-a5e0-e37812dfa3e9"),("SUMX2PY2","SUMX2PY2-function-826b60b4-0aa2-4e5e-81d2-be704d3d786f"),("SUMXMY2","SUMXMY2-function-9d144ac1-4d79-43de-b524-e2ecee23b299"),("TAN","TAN-function-08851a40-179f-4052-b789-d7f699447401"),("TANH","TANH-function-017222f0-a0c3-4f69-9787-b3202295dc6c"),("TRUNC","TRUNC-function-8b86a64c-3127-43db-ba14-aa5ceb292721"),("AVEDEV","AVEDEV-function-58fe8d65-2a84-4dc7-8052-f3f87b5c6639"),("AVERAGE","AVERAGE-function-047bac88-d466-426c-a32b-8f33eb960cf6"),("AVERAGEA","AVERAGEA-function-f5f84098-d453-4f4c-bbba-3d2c66356091"),("AVERAGEIF","AVERAGEIF-function-faec8e2e-0dec-4308-af69-f5576d8ac642"),("AVERAGEIFS","AVERAGEIFS-function-48910c45-1fc0-4389-a028-f7c5c3001690"),("BETA.DIST","BETADIST-function-11188c9c-780a-42c7-ba43-9ecb5a878d31"),("BETA.INV","BETAINV-function-e84cb8aa-8df0-4cf6-9892-83a341d252eb"),("BINOM.DIST","BINOMDIST-function-c5ae37b6-f39c-4be2-94c2-509a1480770c"),("BINOM.DIST.RANGE","BINOMDISTRANGE-function-17331329-74c7-4053-bb4c-6653a7421595"),("BINOM.INV","BINOMINV-function-80a0370c-ada6-49b4-83e7-05a91ba77ac9"),("CHISQ.DIST","CHISQDIST-function-8486b05e-5c05-4942-a9ea-f6b341518732"),("CHISQ.DIST.RT","CHISQDISTRT-function-dc4832e8-ed2b-49ae-8d7c-b28d5804c0f2"),("CHISQ.INV","CHISQINV-function-400db556-62b3-472d-80b3-254723e7092f"),("CHISQ.INV.RT","CHISQINVRT-function-435b5ed8-98d5-4da6-823f-293e2cbc94fe"),("CHISQ.TEST","CHISQTEST-function-2e8a7861-b14a-4985-aa93-fb88de3f260f"),("CONFIDENCE.NORM","CONFIDENCENORM-function-7cec58a6-85bb-488d-91c3-63828d4fbfd4"),("CONFIDENCE.T","CONFIDENCET-function-e8eca395-6c3a-4ba9-9003-79ccc61d3c53"),("CORREL","CORREL-function-995dcef7-0c0a-4bed-a3fb-239d7b68ca92"),("COUNT","COUNT-function-a59cd7fc-b623-4d93-87a4-d23bf411294c"),("COUNTA","COUNTA-function-7dc98875-d5c1-46f1-9a82-53f3219e2509"),("COUNTBLANK","COUNTBLANK-function-6a92d772-675c-4bee-b346-24af6bd3ac22"),("COUNTIF","COUNTIF-function-e0de10c6-f885-4e71-abb4-1f464816df34"),("COUNTIFS","COUNTIFS-function-dda3dc6e-f74e-4aee-88bc-aa8c2a866842"),("COVARIANCE.P","COVARIANCEP-function-6f0e1e6d-956d-4e4b-9943-cfef0bf9edfc"),("COVARIANCE.S","COVARIANCES-function-0a539b74-7371-42aa-a18f-1f5320314977"),("DEVSQ","DEVSQ-function-8b739616-8376-4df5-8bd0-cfe0a6caf444"),("EXPON.DIST","EXPONDIST-function-4c12ae24-e563-4155-bf3e-8b78b6ae140e"),("F.DIST","FDIST-function-a887efdc-7c8e-46cb-a74a-f884cd29b25d"),("F.DIST.RT","FDISTRT-function-d74cbb00-6017-4ac9-b7d7-6049badc0520"),("F.INV","FINV-function-0dda0cf9-4ea0-42fd-8c3c-417a1ff30dbe"),("F.INV.RT","FINVRT-function-d371aa8f-b0b1-40ef-9cc2-496f0693ac00"),("F.TEST","FTEST-function-100a59e7-4108-46f8-8443-78ffacb6c0a7"),("FISHER","FISHER-function-d656523c-5076-4f95-b87b-7741bf236c69"),("FISHERINV","FISHERINV-function-62504b39-415a-4284-a285-19c8e82f86bb"),("FORECAST","FORECAST-function-50ca49c9-7b40-4892-94e4-7ad38bbeda99"),("FORECAST.ETS","FORECASTETS-function-897a2fe9-6595-4680-a0b0-93e0308d5f6e#_forecast.ets"),("FORECAST.ETS.CONFINT","FORECASTETSCONFINT-function-897a2fe9-6595-4680-a0b0-93e0308d5f6e#_forecast.ets.confint"),("FORECAST.ETS.SEASONALITY","FORECASTETSSEASONALITY-function-897a2fe9-6595-4680-a0b0-93e0308d5f6e#_forecast.ets.seasonality"),("FORECAST.ETS.STAT","FORECASTETSSTAT-function-897a2fe9-6595-4680-a0b0-93e0308d5f6e#_forecast.ets.stat"),("FORECAST.LINEAR","FORECASTLINEAR-function-897a2fe9-6595-4680-a0b0-93e0308d5f6e#_forecast.linear"),("FREQUENCY","FREQUENCY-function-44e3be2b-eca0-42cd-a3f7-fd9ea898fdb9"),("GAMMA","GAMMA-function-ce1702b1-cf55-471d-8307-f83be0fc5297"),("GAMMA.DIST","GAMMADIST-function-9b6f1538-d11c-4d5f-8966-21f6a2201def"),("GAMMA.INV","GAMMAINV-function-74991443-c2b0-4be5-aaab-1aa4d71fbb18"),("GAMMALN","GAMMALN-function-b838c48b-c65f-484f-9e1d-141c55470eb9"),("GAMMALN.PRECISE","GAMMALNPRECISE-function-5cdfe601-4e1e-4189-9d74-241ef1caa599"),("GAUSS","GAUSS-function-069f1b4e-7dee-4d6a-a71f-4b69044a6b33"),("GEOMEAN","GEOMEAN-function-db1ac48d-25a5-40a0-ab83-0b38980e40d5"),("GROWTH","GROWTH-function-541a91dc-3d5e-437d-b156-21324e68b80d"),("HARMEAN","HARMEAN-function-5efd9184-fab5-42f9-b1d3-57883a1d3bc6"),("HYPGEOM.DIST","HYPGEOMDIST-function-6dbd547f-1d12-4b1f-8ae5-b0d9e3d22fbf"),("INTERCEPT","INTERCEPT-function-2a9b74e2-9d47-4772-b663-3bca70bf63ef"),("KURT","KURT-function-bc3a265c-5da4-4dcb-b7fd-c237789095ab"),("LARGE","LARGE-function-3af0af19-1190-42bb-bb8b-01672ec00a64"),("LINEST","LINEST-function-84d7d0d9-6e50-4101-977a-fa7abf772b6d"),("LOGEST","LOGEST-function-f27462d8-3657-4030-866b-a272c1d18b4b"),("LOGNORM.DIST","LOGNORMDIST-function-eb60d00b-48a9-4217-be2b-6074aee6b070"),("LOGNORM.INV","LOGNORMINV-function-fe79751a-f1f2-4af8-a0a1-e151b2d4f600"),("MAX","MAX-function-e0012414-9ac8-4b34-9a47-73e662c08098"),("MAXA","MAXA-function-814bda1e-3840-4bff-9365-2f59ac2ee62d"),("MEDIAN","MEDIAN-function-d0916313-4753-414c-8537-ce85bdd967d2"),("MIN","MIN-function-61635d12-920f-4ce2-a70f-96f202dcc152"),("MINA","MINA-function-245a6f46-7ca5-4dc7-ab49-805341bc31d3"),("MODE.MULT","MODEMULT-function-50fd9464-b2ba-4191-b57a-39446689ae8c"),("MODE.SNGL","MODESNGL-function-f1267c16-66c6-4386-959f-8fba5f8bb7f8"),("NEGBINOM.DIST","NEGBINOMDIST-function-c8239f89-c2d0-45bd-b6af-172e570f8599"),("NORM.DIST","NORMDIST-function-edb1cc14-a21c-4e53-839d-8082074c9f8d"),("NORM.INV","NORMINV-function-54b30935-fee7-493c-bedb-2278a9db7e13"),("NORM.S.DIST","NORMSDIST-function-1e787282-3832-4520-a9ae-bd2a8d99ba88"),("NORM.S.INV","NORMSINV-function-d6d556b4-ab7f-49cd-b526-5a20918452b1"),("PEARSON","PEARSON-function-0c3e30fc-e5af-49c4-808a-3ef66e034c18"),("PERCENTILE.EXC","PERCENTILEEXC-function-bbaa7204-e9e1-4010-85bf-c31dc5dce4ba"),("PERCENTILE.INC","PERCENTILEINC-function-680f9539-45eb-410b-9a5e-c1355e5fe2ed"),("PERCENTRANK.EXC","PERCENTRANKEXC-function-d8afee96-b7e2-4a2f-8c01-8fcdedaa6314"),("PERCENTRANK.INC","PERCENTRANKINC-function-149592c9-00c0-49ba-86c1-c1f45b80463a"),("PERMUT","PERMUT-function-3bd1cb9a-2880-41ab-a197-f246a7a602d3"),("PERMUTATIONA","PERMUTATIONA-function-6c7d7fdc-d657-44e6-aa19-2857b25cae4e"),("PHI","PHI-function-23e49bc6-a8e8-402d-98d3-9ded87f6295c"),("POISSON.DIST","POISSONDIST-function-8fe148ff-39a2-46cb-abf3-7772695d9636"),("PROB","PROB-function-9ac30561-c81c-4259-8253-34f0a238fc49"),("QUARTILE.EXC","QUARTILEEXC-function-5a355b7a-840b-4a01-b0f1-f538c2864cad"),("QUARTILE.INC","QUARTILEINC-function-1bbacc80-5075-42f1-aed6-47d735c4819d"),("RANK.AVG","RANKAVG-function-bd406a6f-eb38-4d73-aa8e-6d1c3c72e83a"),("RANK.EQ","RANKEQ-function-284858ce-8ef6-450e-b662-26245be04a40"),("RSQ","RSQ-function-d7161715-250d-4a01-b80d-a8364f2be08f"),("SKEW","SKEW-function-bdf49d86-b1ef-4804-a046-28eaea69c9fa"),("SKEW.P","SKEWP-function-76530a5c-99b9-48a1-8392-26632d542fcb"),("SLOPE","SLOPE-function-11fb8f97-3117-4813-98aa-61d7e01276b9"),("SMALL","SMALL-function-17da8222-7c82-42b2-961b-14c45384df07"),("STANDARDIZE","STANDARDIZE-function-81d66554-2d54-40ec-ba83-6437108ee775"),("STDEV.P","STDEVP-function-6e917c05-31a0-496f-ade7-4f4e7462f285"),("STDEV.S","STDEVS-function-7d69cf97-0c1f-4acf-be27-f3e83904cc23"),("STDEVA","STDEVA-function-5ff38888-7ea5-48de-9a6d-11ed73b29e9d"),("STDEVPA","STDEVPA-function-5578d4d6-455a-4308-9991-d405afe2c28c"),("STEYX","STEYX-function-6ce74b2c-449d-4a6e-b9ac-f9cef5ba48ab"),("T.DIST","TDIST-function-4329459f-ae91-48c2-bba8-1ead1c6c21b2"),("T.DIST.2T","TDIST2T-function-198e9340-e360-4230-bd21-f52f22ff5c28"),("T.DIST.RT","TDISTRT-function-20a30020-86f9-4b35-af1f-7ef6ae683eda"),("T.INV","TINV-function-2908272b-4e61-4942-9df9-a25fec9b0e2e"),("T.INV.2T","TINV2T-function-ce72ea19-ec6c-4be7-bed2-b9baf2264f17"),("T.TEST","TTEST-function-d4e08ec3-c545-485f-962e-276f7cbed055"),("TREND","TREND-function-e2f135f0-8827-4096-9873-9a7cf7b51ef1"),("TRIMMEAN","TRIMMEAN-function-d90c9878-a119-4746-88fa-63d988f511d3"),("VAR.P","VARP-function-73d1285c-108c-4843-ba5d-a51f90656f3a"),("VAR.S","VARS-function-913633de-136b-449d-813e-65a00b2b990b"),("VARA","VARA-function-3de77469-fa3a-47b4-85fd-81758a1e1d07"),("VARPA","VARPA-function-59a62635-4e89-4fad-88ac-ce4dc0513b96"),("WEIBULL.DIST","WEIBULLDIST-function-4e783c39-9325-49be-bbc9-a83ef82b45db"),("Z.TEST","ZTEST-function-d633d5a3-2031-4614-a016-92180ad82bee"),("ASC","ASC-function-0b6abf1c-c663-4004-a964-ebc00b723266"),("BAHTTEXT","BAHTTEXT-function-5ba4d0b4-abd3-4325-8d22-7a92d59aab9c"),("CHAR","CHAR-function-bbd249c8-b36e-4a91-8017-1c133f9b837a"),("CLEAN","CLEAN-function-26f3d7c5-475f-4a9c-90e5-4b8ba987ba41"),("CODE","CODE-function-c32b692b-2ed0-4a04-bdd9-75640144b928"),("CONCATENATE","CONCATENATE-function-8f8ae884-2ca8-4f7a-b093-75d702bea31d"),("DBCS","DBCS-function-a4025e73-63d2-4958-9423-21a24794c9e5"),("DOLLAR","DOLLAR-function-a6cd05d9-9740-4ad3-a469-8109d18ff611"),("EXACT","EXACT-function-d3087698-fc15-4a15-9631-12575cf29926"),("FIND","FIND-FINDB-functions-c7912941-af2a-4bdf-a553-d0d89b0a0628"),("FINDB","FIND-FINDB-functions-c7912941-af2a-4bdf-a553-d0d89b0a0628"),("FIXED","FIXED-function-ffd5723c-324c-45e9-8b96-e41be2a8274a"),("LEFT","LEFT-LEFTB-functions-9203d2d2-7960-479b-84c6-1ea52b99640c"),("LEFTB","LEFT-LEFTB-functions-9203d2d2-7960-479b-84c6-1ea52b99640c"),("LEN","LEN-LENB-functions-29236f94-cedc-429d-affd-b5e33d2c67cb"),("LENB","LEN-LENB-functions-29236f94-cedc-429d-affd-b5e33d2c67cb"),("LOWER","LOWER-function-3f21df02-a80c-44b2-afaf-81358f9fdeb4"),("MID","MID-MIDB-functions-d5f9e25c-d7d6-472e-b568-4ecb12433028"),("MIDB","MID-MIDB-functions-d5f9e25c-d7d6-472e-b568-4ecb12433028"),("NUMBERVALUE","NUMBERVALUE-function-1b05c8cf-2bfa-4437-af70-596c7ea7d879"),("PHONETIC","PHONETIC-function-9a329dac-0c0f-42f8-9a55-639086988554"),("PROPER","PROPER-function-52a5a283-e8b2-49be-8506-b2887b889f94"),("REPLACE","REPLACE-REPLACEB-functions-8d799074-2425-4a8a-84bc-82472868878a"),("REPLACEB","REPLACE-REPLACEB-functions-8d799074-2425-4a8a-84bc-82472868878a"),("REPT","REPT-function-04c4d778-e712-43b4-9c15-d656582bb061"),("RIGHT","RIGHT-RIGHTB-functions-240267ee-9afa-4639-a02b-f19e1786cf2f"),("RIGHTB","RIGHT-RIGHTB-functions-240267ee-9afa-4639-a02b-f19e1786cf2f"),("SEARCH","SEARCH-SEARCHB-functions-9ab04538-0e55-4719-a72e-b6f54513b495"),("SEARCHB","SEARCH-SEARCHB-functions-9ab04538-0e55-4719-a72e-b6f54513b495"),("SUBSTITUTE","SUBSTITUTE-function-6434944e-a904-4336-a9b0-1e58df3bc332"),("T","T-function-fb83aeec-45e7-4924-af95-53e073541228"),("TEXT","TEXT-function-20d5ac4d-7b94-49fd-bb38-93d29371225c"),("TRIM","TRIM-function-410388fa-c5df-49c6-b16c-9e5630b479f9"),("UNICHAR","UNICHAR-function-ffeb64f5-f131-44c6-b332-5cd72f0659b8"),("UNICODE","UNICODE-function-adb74aaa-a2a5-4dde-aff6-966e4e81f16f"),("UPPER","UPPER-function-c11f29b3-d1a3-4537-8df6-04d0049963d6"),("VALUE","VALUE-function-257d0108-07dc-437d-ae1c-bc2d3953d8c2"),("CALL","CALL-function-32d58445-e646-4ffd-8d5e-b45077a5e995"),("EUROCONVERT","EUROCONVERT-function-79c8fd67-c665-450c-bb6c-15fc92f8345c"),("REGISTER.ID","REGISTERID-function-f8f0af0f-fd66-4704-a0f2-87b27b175b50"),("SQL.REQUEST","SQLREQUEST-function-4da47f3a-ff08-46ed-886c-3329aa5df008"),("ENCODEURL","ENCODEURL-function-07c7fb90-7c60-4bff-8687-fac50fe33d0e"),("FILTERXML","FILTERXML-function-4df72efc-11ec-4951-86f5-c1374812f5b7"),("WEBSERVICE","WEBSERVICE-function-0546a35a-ecc6-4739-aed7-c0b7ce1562c4")]