New Webapp

.devcontainer/Dockerfile

@@ -1,4 +1,4 @@
-FROM mistzzt/haskell-ide-engine:0.11-ghc8.4.4
+FROM mistzzt/haskell-ide-engine:1.4-ghc8.4.4
 
 # Avoid warnings by switching to noninteractive
 ENV DEBIAN_FRONTEND=noninteractive

.devcontainer/devcontainer.json

@@ -1,6 +1,6 @@
 {
-    "name": "H+ w/ HIE(G) 0.11",
-    "image": "mistzzt/hoogle_plus_dev:latest",
+    "name": "H+ w/ HIE 1.4, GHC 8.4.4",
+    "image": "mistzzt/hoogle_plus_dev:hie1.4_ghc8.4.4",
 
     "extensions": [
         "eamodio.gitlens",

.gitignore

@@ -44,3 +44,45 @@ benchmark/suites/working.yml
 .elasticbeanstalk/*
 !.elasticbeanstalk/*.cfg.yml
 !.elasticbeanstalk/*.global.yml
+
+node_modules/
+.yarn
+# See https://help.github.com/articles/ignoring-files/ for more about ignoring files.
+
+# dependencies
+/node_modules
+/.pnp
+.pnp.js
+
+# testing
+/coverage
+
+# production
+/build
+
+# misc
+.DS_Store
+.env.local
+.env.development.local
+.env.test.local
+.env.production.local
+
+npm-debug.log*
+yarn-debug.log*
+yarn-error.log*
+
+# flask
+venv/
+
+*.pyc
+__pycache__/
+
+instance/
+
+.pytest_cache/
+.coverage
+htmlcov/
+
+dist/
+build/
+*.egg-info/

InternalTypeGen.hs

@@ -1,39 +1,211 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, LambdaCase, FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances, FunctionalDependencies #-}
 module InternalTypeGen where
 
-import Test.QuickCheck.Arbitrary
-import Test.QuickCheck.Gen
+import Data.List (isInfixOf, elemIndex, nub, drop, reverse, intersect)
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Logic
+import Data.Data
+
+import Text.Printf
+import System.IO.Silently
+import Control.Lens
+import Debug.Trace
+
+import qualified Test.LeanCheck.Function.ShowFunction as SF
+import qualified Test.LeanCheck.Core as SF
 import qualified Test.ChasingBottoms as CB
-import Data.Map (Map)
-import Data.List (isInfixOf)
-import Control.Applicative
-
-isEqualResult lhs rhs = case (lhs, rhs) of
-  (CB.Value a, CB.Value b) -> a == b
-  (CB.NonTermination, CB.NonTermination) -> True
-  (CB.Exception _, CB.Exception _) -> True
-  _ -> False
+import qualified Test.SmallCheck.Series as SS
+import qualified Test.QuickCheck as QC
+
+defaultShowFunctionDepth = 4 :: Int
+defaultMaxOutputLength = 10 :: CB.Nat
+defaultSeriesLimit = 5 :: Int
 
+instance Eq a => Eq (CB.Result a) where
+  (CB.Value a) == (CB.Value b) = a == b
+  CB.NonTermination == CB.NonTermination = True
+  (CB.Exception _) == (CB.Exception _) = True
+  _ == _ = False
+
+isFailedResult :: CB.Result String -> Bool
 isFailedResult result = case result of
   CB.NonTermination -> True
   CB.Exception _ -> True
   CB.Value a | "_|_" `isInfixOf` a -> True
   CB.Value a | "Exception" `isInfixOf` a -> True
   _ -> False
 
-newtype Internal a = Val a
+data MyInt = MOne | Zero | One | Two | Other Int deriving (Eq)
+
+instance Show MyInt where
+  show = show . toInt
+
+toInt :: MyInt -> Int
+toInt MOne = -1
+toInt Zero = 0
+toInt One = 1
+toInt Two = 2
+toInt (Other n) = n
+
+toMyInt :: Int -> MyInt
+toMyInt (-1) = MOne
+toMyInt 0 = Zero
+toMyInt 1 = One
+toMyInt 2 = Two
+toMyInt n = Other n
+
+instance SF.Listable MyInt where
+  tiers = SF.cons0 MOne SF.\/
+          SF.cons0 Zero SF.\/
+          SF.cons0 One SF.\/
+          SF.cons0 Two SF.\/
+          SF.cons1 Other
+
+instance Monad m => SS.Serial m MyInt where
+  series = SS.cons0 MOne SS.\/
+           SS.cons0 Zero SS.\/
+           SS.cons0 One SS.\/
+           SS.cons0 Two
+
+instance Monad m => SS.CoSerial m MyInt where
+  coseries r = let rs = SS.limit defaultSeriesLimit r
+                in SS.alts0 rs >>- \z1 ->
+                   SS.alts0 rs >>- \z2 ->
+                   SS.alts0 rs >>- \z3 ->
+                   SS.alts0 rs >>- \z4 ->
+                   return $ \x ->
+                       case x of
+                           MOne -> z1
+                           Zero -> z2
+                           One -> z3
+                           Two -> z4
+
+newtype MyFun a b = MyFun (a -> b)
+
+instance (QC.CoArbitrary a, QC.Arbitrary b) => QC.Arbitrary (MyFun a b) where
+  arbitrary = liftM MyFun QC.arbitrary
+
+instance (QC.Arbitrary a, QC.CoArbitrary b) => QC.CoArbitrary (MyFun a b) where
+  coarbitrary (MyFun f) = QC.coarbitrary f
+
+instance {-# OVERLAPPABLE #-} (SS.Serial m b, SS.CoSerial m a) => SS.Serial m (MyFun a b) where
+  series = SS.coseries SS.series >>-
+            \f -> return (MyFun f)
+
+instance {-# OVERLAPPING #-} Monad m => SS.Serial m (MyFun Int Int) where
+  series = (SS.generate $ \_ -> map MyFun [\x -> x + 1
+                                          ,\x -> x * x
+                                          ,\x -> x * 3]) SS.\/
+            SS.newtypeCons MyFun
+instance {-# OVERLAPPING #-} Monad m => SS.Serial m (MyFun MyInt Int) where
+  series = (SS.generate $ \_ -> map MyFun [\x -> toInt x + 1
+                                          ,\x -> toInt x * toInt x
+                                          ,\x -> toInt x * 3]) SS.\/
+            (SS.coseries SS.series >>- 
+                \f -> return (MyFun f))
+instance {-# OVERLAPPING #-} Monad m => SS.Serial m (MyFun [Int] [Int]) where
+  series = (SS.generate $ \_ -> map MyFun [\x -> x ++ x]) SS.\/
+            SS.newtypeCons MyFun
+instance (SS.CoSerial m a, SS.Serial m a, SS.Serial m b, SS.CoSerial m b) => SS.CoSerial m (MyFun a b) where
+  coseries rs = SS.newtypeAlts rs >>- \f ->
+                return $ \(MyFun x) -> f x
+
+instance {-# OVERLAPPABLE #-} (Show a, SF.Listable a, SF.ShowFunction b) => Show (MyFun a b) where
+  show (MyFun f) = "(" ++ SF.showFunctionLine defaultShowFunctionDepth f ++ ")"
+instance {-# OVERLAPPING #-} (SF.ShowFunction b) => Show (MyFun MyInt b) where
+  show (MyFun f) = "(" ++ SF.showFunctionLine defaultShowFunctionDepth (\x -> f (toMyInt x)) ++ ")"
+
+instance SF.ShowFunction MyInt where
+  bindtiers = SF.bindtiers . toInt
+instance (Show a, SF.Listable a, SF.ShowFunction b) => SF.ShowFunction (MyFun a b) where
+  bindtiers (MyFun f) = SF.bindtiers f
+
+class Unwrappable a b where
+  unwrap :: a -> b
+  wrap :: b -> a
+
+instance {-# OVERLAPPABLE #-} (a ~ b) => Unwrappable a b where
+  unwrap = id
+  wrap = id
+instance Unwrappable MyInt Int where
+  unwrap = toInt
+  wrap = toMyInt
+instance (Unwrappable a c, Unwrappable b d) => Unwrappable (MyFun a b) (c -> d) where
+  unwrap (MyFun f) = \x -> unwrap (f (wrap x))
+  wrap f = MyFun $ \x -> wrap (f (unwrap x))
+instance (Unwrappable a b) => Unwrappable [a] [b] where
+  unwrap = map unwrap
+  wrap = map wrap
+instance {-# OVERLAPPING #-} (Unwrappable a b) => Unwrappable (Maybe a) (Maybe b) where
+  unwrap = fmap unwrap
+  wrap = fmap wrap
+instance (Unwrappable a c, Unwrappable b d) => Unwrappable (a, b) (c, d) where
+  unwrap (x, y) = (unwrap x, unwrap y)
+  wrap (x, y) = (wrap x, wrap y)
+
+
+showCBResult :: CB.Result String -> String
+showCBResult = \case
+                  CB.Value a | "_|_" `isInfixOf` a -> "bottom"
+                  CB.Value a -> a
+                  CB.NonTermination -> "diverge"
+                  CB.Exception ex -> show ex
+
+anyDuplicate :: Eq a => [a] -> Bool
+-- anyDuplicate xs = length (nub xs) /= length xs
+anyDuplicate [] = False
+anyDuplicate (x:xs) = x `elem` xs 
+
+-- * instance defined in `Types.IOFormat`
+data Example = Example {
+    inputs :: [String],
+    output :: String
+} deriving(Eq, Show)
+
+type ExampleGeneration m = StateT [Example] m
+
+evaluateIOQC :: Show a => [String] -> a -> ExampleGeneration IO String
+evaluateIOQC inputs val = do
+    let result = show val
+    modify ((Example inputs result):)
+    return result
 
-instance Show a => Show (Internal a) where
-  show (Val value) = show value
+evaluateIO :: Data a => Int -> [String] -> [a] -> ExampleGeneration IO ([CB.Result String])
+evaluateIO timeInMicro inputs vals = do
+    results <- liftIO $ silence $ mapM (CB.timeOutMicro timeInMicro . eval) vals
+
+    let resultsStr = map showCBResult results
+    modify ((++) (map (Example inputs) resultsStr))
+    return results
+  where
+    evalStr val = CB.approxShow defaultMaxOutputLength val
+    io str = ((putStrLn str) >> return str)
 
-instance Arbitrary a => Arbitrary (Internal a) where
-  arbitrary = Val <$> arbitrary
+    eval val = io (evalStr val)
+
+waitState :: Int -> [String] -> [String] -> [[String]] -> CB.Result String -> ExampleGeneration IO Bool
+waitState numIOs args previousRets previousArgs ret = case (not $ isFailedResult ret) of
+  False -> pure False
+  _ -> do
+    ioState <- get
 
-instance {-# OVERLAPPING #-} Arbitrary (Internal Int) where
-  arbitrary = Val <$> choose (5, 10)
+    let retStr = showCBResult ret
+    when (retIsNotInState retStr ioState && paramsIsNotInState args ioState)
+        (modify ((:) (Example args retStr)))
 
-instance {-# OVERLAPPING #-} Arbitrary (Internal Char) where
-  arbitrary = Val <$> choose ('A', 'D')
+    state <- get
+    return ((length state) == numIOs)
+  where 
+    retIsNotInState retStr state = not $ ((retStr `elem` (map output state)) || (retStr `elem` previousRets))
+    paramsIsNotInState params state = not (anyCommonArgs params (map inputs state ++ previousArgs))
 
-instance {-# OVERLAPPING #-} Arbitrary (Internal String) where
-  arbitrary = Val <$> vectorOf 5 (choose ('A', 'D'))
+-- modify 2020/04/22 by Zheng
+-- only compare arguments in the same position, intersect is too strict
+anyCommonArgs :: [String] -> [[String]] -> Bool
+anyCommonArgs args inputs = or $ map (compare args) inputs
+  where
+    compare :: [String] -> [String] -> Bool
+    compare xs = any (uncurry (==)) . zip xs